{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
module Language.Cimple.DescribeAst
    ( HasLocation (..)
    , describeLexeme
    , describeNode
    , parseError
    ) where

import           Data.Fix                (Fix (..), foldFix)
import           Data.List               (isPrefixOf, (\\))
import qualified Data.List               as List
import           Data.Text               (Text)
import qualified Data.Text               as Text
import           Language.Cimple.Ast     (Node, NodeF (..))
import qualified Language.Cimple.Flatten as Flatten
import           Language.Cimple.Lexer   (Alex, AlexPosn (..), Lexeme (..),
                                          alexError, lexemeLine)
import           Language.Cimple.Tokens  (LexemeClass (..))


class HasLocation a where
    sloc :: FilePath -> a -> Text

instance HasLocation (Lexeme text) where
    sloc :: FilePath -> Lexeme text -> Text
sloc FilePath
file Lexeme text
l = FilePath -> Text
Text.pack FilePath
file Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show (Lexeme text -> Int
forall text. Lexeme text -> Int
lexemeLine Lexeme text
l))

instance HasLocation lexeme => HasLocation (Node lexeme) where
    sloc :: FilePath -> Node lexeme -> Text
sloc FilePath
file Node lexeme
n =
        case (NodeF lexeme [lexeme] -> [lexeme]) -> Node lexeme -> [lexeme]
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix NodeF lexeme [lexeme] -> [lexeme]
forall lexeme. NodeF lexeme [lexeme] -> [lexeme]
Flatten.lexemes Node lexeme
n of
            []  -> FilePath -> Text
Text.pack FilePath
file Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":0:0"
            lexeme
l:[lexeme]
_ -> FilePath -> lexeme -> Text
forall a. HasLocation a => FilePath -> a -> Text
sloc FilePath
file lexeme
l


describeNode :: Show a => Node a -> String
describeNode :: Node a -> FilePath
describeNode Node a
node = case Node a -> NodeF a (Node a)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node a
node of
    PreprocIf{}     -> FilePath
"#if/#endif block"
    PreprocIfdef{}  -> FilePath
"#ifdef/#endif block"
    PreprocIfndef{} -> FilePath
"#ifndef/#endif block"
    NodeF a (Node a)
_               -> NodeF a FilePath -> FilePath
forall a. Show a => a -> FilePath
show (NodeF a FilePath -> FilePath) -> NodeF a FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
ellipsis FilePath -> NodeF a (Node a) -> NodeF a FilePath
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Node a -> NodeF a (Node a)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node a
node
  where
    ellipsis :: String
    ellipsis :: FilePath
ellipsis = FilePath
"..."

describeLexemeClass :: LexemeClass -> Maybe String
describeLexemeClass :: LexemeClass -> Maybe FilePath
describeLexemeClass = LexemeClass -> Maybe FilePath
forall a. IsString a => LexemeClass -> Maybe a
d
  where
    d :: LexemeClass -> Maybe a
d LexemeClass
IdConst               = a -> Maybe a
forall a. a -> Maybe a
Just a
"constant name"
    d LexemeClass
IdFuncType            = a -> Maybe a
forall a. a -> Maybe a
Just a
"function type name"
    d LexemeClass
IdStdType             = a -> Maybe a
forall a. a -> Maybe a
Just a
"standard type name"
    d LexemeClass
IdSueType             = a -> Maybe a
forall a. a -> Maybe a
Just a
"type name"
    d LexemeClass
IdVar                 = a -> Maybe a
forall a. a -> Maybe a
Just a
"variable name"
    d LexemeClass
LitChar               = a -> Maybe a
forall a. a -> Maybe a
Just a
"character literal"
    d LexemeClass
LitInteger            = a -> Maybe a
forall a. a -> Maybe a
Just a
"integer literal"
    d LexemeClass
LitString             = a -> Maybe a
forall a. a -> Maybe a
Just a
"string literal"
    d LexemeClass
LitSysInclude         = a -> Maybe a
forall a. a -> Maybe a
Just a
"system include"
    d LexemeClass
PctAmpersand          = a -> Maybe a
forall a. a -> Maybe a
Just a
"address-of or bitwise-and operator"
    d LexemeClass
PctAmpersandAmpersand = a -> Maybe a
forall a. a -> Maybe a
Just a
"logical-and operator"
    d LexemeClass
PctAmpersandEq        = a -> Maybe a
forall a. a -> Maybe a
Just a
"bitwise-and-assign operator"
    d LexemeClass
PctArrow              = a -> Maybe a
forall a. a -> Maybe a
Just a
"pointer-member-access operator"
    d LexemeClass
PctAsterisk           = a -> Maybe a
forall a. a -> Maybe a
Just a
"pointer-type, dereference, or multiply operator"
    d LexemeClass
PctAsteriskEq         = a -> Maybe a
forall a. a -> Maybe a
Just a
"multiply-assign operator"
    d LexemeClass
PctCaret              = a -> Maybe a
forall a. a -> Maybe a
Just a
"bitwise-xor operator"
    d LexemeClass
PctCaretEq            = a -> Maybe a
forall a. a -> Maybe a
Just a
"xor-assign operator"
    d LexemeClass
PctColon              = a -> Maybe a
forall a. a -> Maybe a
Just a
"ternary operator"
    d LexemeClass
PctComma              = a -> Maybe a
forall a. a -> Maybe a
Just a
"comma"
    d LexemeClass
PctEllipsis           = a -> Maybe a
forall a. a -> Maybe a
Just a
"ellipsis"
    d LexemeClass
PctEMark              = a -> Maybe a
forall a. a -> Maybe a
Just a
"logical not operator"
    d LexemeClass
PctEMarkEq            = a -> Maybe a
forall a. a -> Maybe a
Just a
"not-equals operator"
    d LexemeClass
PctEq                 = a -> Maybe a
forall a. a -> Maybe a
Just a
"assignment operator"
    d LexemeClass
PctEqEq               = a -> Maybe a
forall a. a -> Maybe a
Just a
"equals operator"
    d LexemeClass
PctGreater            = a -> Maybe a
forall a. a -> Maybe a
Just a
"greater-than operator"
    d LexemeClass
PctGreaterEq          = a -> Maybe a
forall a. a -> Maybe a
Just a
"greater-or-equals operator"
    d LexemeClass
PctGreaterGreater     = a -> Maybe a
forall a. a -> Maybe a
Just a
"right-shift operator"
    d LexemeClass
PctGreaterGreaterEq   = a -> Maybe a
forall a. a -> Maybe a
Just a
"right-shift-assign operator"
    d LexemeClass
PctLBrace             = a -> Maybe a
forall a. a -> Maybe a
Just a
"left brace"
    d LexemeClass
PctLBrack             = a -> Maybe a
forall a. a -> Maybe a
Just a
"left square bracket"
    d LexemeClass
PctLess               = a -> Maybe a
forall a. a -> Maybe a
Just a
"less-than operator"
    d LexemeClass
PctLessEq             = a -> Maybe a
forall a. a -> Maybe a
Just a
"less-or-equals operator"
    d LexemeClass
PctLessLess           = a -> Maybe a
forall a. a -> Maybe a
Just a
"left-shift operator"
    d LexemeClass
PctLessLessEq         = a -> Maybe a
forall a. a -> Maybe a
Just a
"left-shift-assign operator"
    d LexemeClass
PctLParen             = a -> Maybe a
forall a. a -> Maybe a
Just a
"left parenthesis"
    d LexemeClass
PctMinus              = a -> Maybe a
forall a. a -> Maybe a
Just a
"minus operator"
    d LexemeClass
PctMinusEq            = a -> Maybe a
forall a. a -> Maybe a
Just a
"minus-assign operator"
    d LexemeClass
PctMinusMinus         = a -> Maybe a
forall a. a -> Maybe a
Just a
"decrement operator"
    d LexemeClass
PctPeriod             = a -> Maybe a
forall a. a -> Maybe a
Just a
"member access operator"
    d LexemeClass
PctPercent            = a -> Maybe a
forall a. a -> Maybe a
Just a
"modulus operator"
    d LexemeClass
PctPercentEq          = a -> Maybe a
forall a. a -> Maybe a
Just a
"modulus-assign operator"
    d LexemeClass
PctPipe               = a -> Maybe a
forall a. a -> Maybe a
Just a
"bitwise-or operator"
    d LexemeClass
PctPipeEq             = a -> Maybe a
forall a. a -> Maybe a
Just a
"bitwise-or-assign operator"
    d LexemeClass
PctPipePipe           = a -> Maybe a
forall a. a -> Maybe a
Just a
"logical-or operator"
    d LexemeClass
PctPlus               = a -> Maybe a
forall a. a -> Maybe a
Just a
"addition operator"
    d LexemeClass
PctPlusEq             = a -> Maybe a
forall a. a -> Maybe a
Just a
"add-assign operator"
    d LexemeClass
PctPlusPlus           = a -> Maybe a
forall a. a -> Maybe a
Just a
"increment operator"
    d LexemeClass
PctQMark              = a -> Maybe a
forall a. a -> Maybe a
Just a
"ternary operator"
    d LexemeClass
PctRBrace             = a -> Maybe a
forall a. a -> Maybe a
Just a
"right brace"
    d LexemeClass
PctRBrack             = a -> Maybe a
forall a. a -> Maybe a
Just a
"right square bracket"
    d LexemeClass
PctRParen             = a -> Maybe a
forall a. a -> Maybe a
Just a
"right parenthesis"
    d LexemeClass
PctSemicolon          = a -> Maybe a
forall a. a -> Maybe a
Just a
"end of statement semicolon"
    d LexemeClass
PctSlash              = a -> Maybe a
forall a. a -> Maybe a
Just a
"division operator"
    d LexemeClass
PctSlashEq            = a -> Maybe a
forall a. a -> Maybe a
Just a
"divide-assign operator"
    d LexemeClass
PctTilde              = a -> Maybe a
forall a. a -> Maybe a
Just a
"bitwise-not operator"
    d LexemeClass
PpDefine              = a -> Maybe a
forall a. a -> Maybe a
Just a
"preprocessor define"
    d LexemeClass
PpDefined             = a -> Maybe a
forall a. a -> Maybe a
Just a
"preprocessor defined"
    d LexemeClass
PpElif                = a -> Maybe a
forall a. a -> Maybe a
Just a
"preprocessor elif"
    d LexemeClass
PpElse                = a -> Maybe a
forall a. a -> Maybe a
Just a
"preprocessor else"
    d LexemeClass
PpEndif               = a -> Maybe a
forall a. a -> Maybe a
Just a
"preprocessor endif"
    d LexemeClass
PpIf                  = a -> Maybe a
forall a. a -> Maybe a
Just a
"preprocessor if"
    d LexemeClass
PpIfdef               = a -> Maybe a
forall a. a -> Maybe a
Just a
"preprocessor ifdef"
    d LexemeClass
PpIfndef              = a -> Maybe a
forall a. a -> Maybe a
Just a
"preprocessor ifndef"
    d LexemeClass
PpInclude             = a -> Maybe a
forall a. a -> Maybe a
Just a
"preprocessor include"
    d LexemeClass
PpNewline             = a -> Maybe a
forall a. a -> Maybe a
Just a
"newline"
    d LexemeClass
PpUndef               = a -> Maybe a
forall a. a -> Maybe a
Just a
"preprocessor undef"
    d LexemeClass
CmtBlock              = a -> Maybe a
forall a. a -> Maybe a
Just a
"block comment"
    d LexemeClass
CmtCommand            = a -> Maybe a
forall a. a -> Maybe a
Just a
"doxygen command"
    d LexemeClass
CmtAttr               = a -> Maybe a
forall a. a -> Maybe a
Just a
"parameter attribute"
    d LexemeClass
CmtEndDocSection      = a -> Maybe a
forall a. a -> Maybe a
Just a
"doxygen end-of-section"
    d LexemeClass
CmtIndent             = a -> Maybe a
forall a. a -> Maybe a
Just a
"indented comment"
    d LexemeClass
CmtStart              = a -> Maybe a
forall a. a -> Maybe a
Just a
"start of comment"
    d LexemeClass
CmtStartCode          = a -> Maybe a
forall a. a -> Maybe a
Just a
"escaped comment"
    d LexemeClass
CmtStartBlock         = a -> Maybe a
forall a. a -> Maybe a
Just a
"block comment"
    d LexemeClass
CmtStartDoc           = a -> Maybe a
forall a. a -> Maybe a
Just a
"doxygen comment"
    d LexemeClass
CmtStartDocSection    = a -> Maybe a
forall a. a -> Maybe a
Just a
"doxygen start-of-section"
    d LexemeClass
CmtSpdxCopyright      = a -> Maybe a
forall a. a -> Maybe a
Just a
"SPDX Copyright"
    d LexemeClass
CmtSpdxLicense        = a -> Maybe a
forall a. a -> Maybe a
Just a
"SPDX License"
    d LexemeClass
CmtCode               = a -> Maybe a
forall a. a -> Maybe a
Just a
"code comment"
    d LexemeClass
CmtWord               = a -> Maybe a
forall a. a -> Maybe a
Just a
"comment word"
    d LexemeClass
CmtRef                = a -> Maybe a
forall a. a -> Maybe a
Just a
"comment reference"
    d LexemeClass
CmtEnd                = a -> Maybe a
forall a. a -> Maybe a
Just a
"end of comment"
    d LexemeClass
IgnStart              = a -> Maybe a
forall a. a -> Maybe a
Just a
"tokstyle ignore start"
    d LexemeClass
IgnBody               = a -> Maybe a
forall a. a -> Maybe a
Just a
"tokstyle ignored code"
    d LexemeClass
IgnEnd                = a -> Maybe a
forall a. a -> Maybe a
Just a
"tokstyle ignore end"

    d LexemeClass
ErrorToken            = a -> Maybe a
forall a. a -> Maybe a
Just a
"lexical error"
    d LexemeClass
Eof                   = a -> Maybe a
forall a. a -> Maybe a
Just a
"end-of-file"
    d LexemeClass
_                     = Maybe a
forall a. Maybe a
Nothing

describeLexeme :: Show a => Lexeme a -> String
describeLexeme :: Lexeme a -> FilePath
describeLexeme (L AlexPosn
_ LexemeClass
c a
s) = FilePath -> (FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" (FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
": ") (LexemeClass -> Maybe FilePath
describeLexemeClass LexemeClass
c) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> a -> FilePath
forall a. Show a => a -> FilePath
show a
s

describeExpected :: [String] -> String
describeExpected :: [FilePath] -> FilePath
describeExpected [] = FilePath
"end of file"
describeExpected [FilePath
"ID_VAR"] = FilePath
"variable name"
describeExpected [FilePath
option] = FilePath
option
describeExpected [FilePath]
options
    | [FilePath] -> Bool
wants [FilePath
"break", FilePath
"const", FilePath
"continue", FilePath
"ID_CONST", FilePath
"VLA"] = FilePath
"statement or declaration"
    | [FilePath] -> Bool
wants [FilePath
"ID_FUNC_TYPE", FilePath
"non_null", FilePath
"static", FilePath
"'#include'"] = FilePath
"top-level declaration or definition"
    | [FilePath]
options [FilePath] -> [FilePath] -> Bool
forall a. Eq a => a -> a -> Bool
== [FilePath
"ID_STD_TYPE", FilePath
"ID_SUE_TYPE", FilePath
"struct", FilePath
"void"] = FilePath
"type specifier"
    | [FilePath]
options [FilePath] -> [FilePath] -> Bool
forall a. Eq a => a -> a -> Bool
== [FilePath
"ID_STD_TYPE", FilePath
"ID_SUE_TYPE", FilePath
"bitwise", FilePath
"const", FilePath
"force", FilePath
"struct", FilePath
"void"] = FilePath
"type specifier"
    | [FilePath]
options [FilePath] -> [FilePath] -> Bool
forall a. Eq a => a -> a -> Bool
== [FilePath
"ID_CONST", FilePath
"ID_VAR", FilePath
"LIT_CHAR", FilePath
"LIT_FALSE", FilePath
"LIT_INTEGER", FilePath
"'{'"] = FilePath
"constant or literal"
    | [FilePath
"ID_FUNC_TYPE", FilePath
"ID_STD_TYPE", FilePath
"ID_SUE_TYPE", FilePath
"ID_VAR"] [FilePath] -> [FilePath] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [FilePath]
options = FilePath
"type specifier or variable name"
    | [FilePath
"ID_FUNC_TYPE", FilePath
"ID_STD_TYPE", FilePath
"ID_SUE_TYPE", FilePath
"bitwise", FilePath
"const"] [FilePath] -> [FilePath] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [FilePath]
options = FilePath
"type specifier"
    | [FilePath
"ID_CONST", FilePath
"sizeof", FilePath
"LIT_CHAR", FilePath
"LIT_FALSE", FilePath
"LIT_TRUE", FilePath
"LIT_INTEGER"] [FilePath] -> [FilePath] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [FilePath]
options = FilePath
"constant expression"
    | [FilePath
"ID_CONST", FilePath
"ID_SUE_TYPE", FilePath
"'/*'"] [FilePath] -> [FilePath] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [FilePath]
options = FilePath
"enumerator, type name, or comment"
    | [FilePath] -> Bool
wants [FilePath
"'defined'"] = FilePath
"preprocessor constant expression"
    | [FilePath] -> Bool
wants [FilePath
"'&'", FilePath
"'&&'", FilePath
"'*'", FilePath
"'=='", FilePath
"';'"] = FilePath
"operator or end of statement"
    | [FilePath] -> Bool
wants [FilePath
"'&'", FilePath
"'&&'", FilePath
"'*'", FilePath
"'^'", FilePath
"'!='"] = FilePath
"operator"
    | [FilePath] -> Bool
wants [FilePath
"ID_CONST", FilePath
"ID_VAR", FilePath
"sizeof", FilePath
"LIT_CHAR", FilePath
"'--'", FilePath
"'&'", FilePath
"'*'"] = FilePath
"expression"
    | [FilePath
"ID_CONST", FilePath
"ID_STD_TYPE", FilePath
"ID_SUE_TYPE", FilePath
"ID_VAR", FilePath
"const", FilePath
"sizeof"] [FilePath] -> [FilePath] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [FilePath]
options = FilePath
"expression or type specifier"
    | [FilePath
"ID_CONST", FilePath
"ID_STD_TYPE", FilePath
"ID_SUE_TYPE", FilePath
"const", FilePath
"sizeof"] [FilePath] -> [FilePath] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [FilePath]
options = FilePath
"constant expression or type specifier"
    | [FilePath
"'&='", FilePath
"'->'", FilePath
"'*='"] [FilePath] -> [FilePath] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [FilePath]
options = FilePath
"assignment or member/array access"
    | [FilePath] -> Bool
wants [FilePath
"CMT_WORD"] = FilePath
"comment contents"

    | [FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
options Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 = [FilePath] -> FilePath
commaOr [FilePath]
options
    | Bool
otherwise           = FilePath
"one of " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
commaOr [FilePath]
options
  where
    wants :: [FilePath] -> Bool
wants [FilePath]
xs = [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([FilePath]
xs [FilePath] -> [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a] -> [a]
\\ [FilePath]
options)

commaOr :: [String] -> String
commaOr :: [FilePath] -> FilePath
commaOr = [FilePath] -> FilePath
go ([FilePath] -> FilePath)
-> ([FilePath] -> [FilePath]) -> [FilePath] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse
  where
    go :: [FilePath] -> FilePath
go []     = FilePath
""
    go (FilePath
x:[FilePath]
xs) = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
List.intercalate FilePath
", " ([FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse [FilePath]
xs) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" or " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
x

parseError :: Show text => (Lexeme text, [String]) -> Alex a
parseError :: (Lexeme text, [FilePath]) -> Alex a
parseError (l :: Lexeme text
l@(L (AlexPn Int
_ Int
line Int
col) LexemeClass
_ text
_), [FilePath]
options) =
    FilePath -> Alex a
forall a. FilePath -> Alex a
alexError (FilePath -> Alex a) -> FilePath -> Alex a
forall a b. (a -> b) -> a -> b
$ FilePath
":" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
line FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
":" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
col FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
": Parse error near " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Lexeme text -> FilePath
forall a. Show a => Lexeme a -> FilePath
describeLexeme Lexeme text
l
        FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"; expected " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
describeExpected [FilePath]
options