module Module where

import IO ( Input, Output, input, output )
import Term ( Term, Identifier, lexer )
import Rule ( Rule )
import qualified Type
import qualified Term
import qualified Rule

import qualified Data.Map as M
import Data.Maybe ( mapMaybe )

import qualified Text.ParserCombinators.Parsec as Parsec
import qualified Text.ParserCombinators.Parsec.Token as Token
import Text.ParserCombinators.Parsec ( (<|>) )
import Text.ParserCombinators.Parsec.Token ( reserved, reservedOp )
import Text.ParserCombinators.Parsec.Expr
           ( Assoc(AssocLeft, AssocRight, AssocNone) )
import Text.PrettyPrint.HughesPJ
           ( (<+>), ($$), empty, hsep, sep, hang, punctuate,
             render, text, comma, vcat, parens )
import qualified Data.Char as Char

import Control.Functor.HT ( void )



nestDepth :: Int
nestDepth = 4

data Import = Import { qualified :: Bool
                     , source :: Name
                     , rename :: Maybe Identifier
                     }
--    deriving (Show)

parsePortList ::
    Parsec.GenParser Char () [Identifier]
parsePortList =
    Token.parens lexer $ flip Parsec.sepEndBy (Token.comma lexer) $
    (do ident <- input
        void $ Parsec.option [] $ Token.parens lexer $
            Token.commaSep lexer $ Token.identifier lexer
        return ident)
    <|>
    Term.parenOperator

{-
A semicolon behind an import statement is necessary when parsing

> import Prelude ;
>
> (+) :: a -> a -> a

otherwise the parentheses around the plus
would be interpreted as parentheses behind @Prelude@.
-}
instance Input Import where
    input = do
      reserved lexer "import"
      q <- Parsec.option False $ do reserved lexer "qualified" ; return True
      t <- input
      r <- Parsec.optionMaybe $ reserved lexer "as" >> input
      void $ Parsec.optionMaybe $ reserved lexer "hiding"
      void $ Parsec.optionMaybe $ parsePortList
      void $ Parsec.option "" $ Token.semi lexer
      return $ Import { qualified = q, source = t, rename = r }

instance Output Import where
    output i = hsep [ text "import"
                    , if qualified i then text "qualified" else empty
                    , output $ source i
                    , case rename i of
                        Nothing -> empty
                        Just r  -> text "as" <+> output r
                    ]


data TypeSig = TypeSig [Identifier] [Term] Term
    deriving (Show)

parseIdentList :: Parsec.CharParser () [Identifier]
parseIdentList =
    Token.commaSep lexer
        (input <|> Term.parenOperator)

instance Input TypeSig where
    input = do
        names <- parseIdentList
        reservedOp lexer "::"
        context <- Type.parseContext
        typeExpr <- Type.parseExpression
        void $ Token.semi lexer
        return $ TypeSig names context typeExpr

instance Output TypeSig where
    output (TypeSig names context typeExpr) =
        hang
            (hsep ( punctuate ( text "," ) $ map output names ) <+> text "::")
            nestDepth
            (sep
                [if null context
                   then empty
                   else parens ( hsep ( punctuate ( text "," ) $
                                 map output context ) ) <+> text "=>",
                 output typeExpr <+> text ";"])


data Data = Data { dataLhs :: Term
                 , dataRhs :: [ Term ]
                 }
    deriving (Show)

instance Input Data where
    input = do
        reserved lexer "data"
        l <- input
        reservedOp lexer "="
        rs <- Parsec.sepBy input ( reservedOp lexer "|" )
        void $ Token.semi lexer
        return $ Data { dataLhs = l, dataRhs = rs }

instance Output Data where
    output d = text "data" <+> output ( dataLhs d ) <+> text "="
        $$ hsep ( punctuate ( text "|" ) $ map output ( dataRhs d ) ) <+> text ";"


data Type = Type { typeLhs :: Term
                 , typeRhs :: Term
                 }
    deriving (Show)

instance Input Type where
    input = do
        reserved lexer "type"
        l <- input
        reservedOp lexer "="
        r <- input
        void $ Token.semi lexer
        return $ Type { typeLhs = l, typeRhs = r }

instance Output Type where
    output d =
        hang
            ( text "type" <+> output ( typeLhs d ) <+> text "=" )
            nestDepth
            ( output ( typeRhs d ) <+> text ";" )


data Infix = Infix Assoc Int [ Identifier ]

showAssoc :: Assoc -> String
showAssoc AssocLeft  = "AssocLeft"
showAssoc AssocRight = "AssocRight"
showAssoc AssocNone  = "AssocNone"

instance Show Infix where
    showsPrec p (Infix assoc prec idents) =
       showParen (p>10) $
       showString "Infix " .
       showString (showAssoc assoc) .
       showString " " .
       shows prec .
       showString " " .
       shows idents

instance Input Infix where
    input = do
        assoc <-
           Parsec.try $
           Token.lexeme lexer $
           Parsec.string "infix" >>
              ((Parsec.char 'l' >> return AssocLeft)
               <|>
               (Parsec.char 'r' >> return AssocRight)
               <|>
               return AssocNone)
        prec <-
           fmap (\c -> Char.ord c - Char.ord '0') $
           Token.lexeme lexer Parsec.digit
        ops <- Parsec.sepBy1 Term.infixOperator (Token.comma lexer)
        void $ Parsec.option "" $ Token.semi lexer
        return $ Infix assoc prec ops

instance Output Infix where
    output (Infix assoc prec idents) =
        let assocStr =
                case assoc of
                    AssocLeft  -> "l"
                    AssocRight -> "r"
                    AssocNone  -> ""
        in  hang
                (text ( "infix" ++ assocStr ) <+> text ( show prec ))
                nestDepth
                (hsep ( punctuate comma $ map output idents ) <+> text ";")


data Declaration = Type_Signature TypeSig
                 | Rule_Declaration Rule
                 | Type_Declaration Type
                 | Data_Declaration Data
                 | Infix_Declaration Infix
    deriving (Show)

instance Input Declaration where
    input = fmap Data_Declaration input
        <|> fmap Infix_Declaration input
        <|> fmap Type_Declaration input
        <|> fmap Type_Signature (do
                names <- Parsec.try $ do
                    names <- parseIdentList
                    reservedOp lexer "::"
                    return names
                context <-
                    Parsec.try Type.parseContext
                    <|>
                    return []
                typeExpr <- Type.parseExpression
                void $ Token.semi lexer
                return $ TypeSig names context typeExpr)
        <|> fmap Rule_Declaration input

instance Output Declaration where
    output decl = case decl of
        Type_Signature d -> output d
        Data_Declaration d -> output d
        Type_Declaration d -> output d
        Rule_Declaration d -> output d
        Infix_Declaration d -> output d

-- | on module parsing:
-- identifiers contain information on their source location.
-- their sourceName (as used by Parsec) is the "show"
-- of the module name (which is an identifier).
-- So, sourceName is NOT the actual file name.
-- instead, the actual file name is kept in source_location (defined here)

data Module = Module
               { name :: Name
               , imports :: [ Import ]
               , declarations :: [ Declaration ]
               , functions :: FunctionDeclarations
               , source_text :: String
               , source_location :: FilePath
               }

newtype Name = Name {deconsName :: String}
    deriving (Eq, Ord)

instance Input Name where
    input = fmap Name Term.identifier

instance Output Name where
    output (Name n) = text n

tellName :: Name -> String
tellName (Name n) = "module " ++ n


type FunctionDeclarations = M.Map Identifier [Rule]

-- | add, or replace (if rule with exact same lhs is already present)
add_rule :: Rule -> Module -> Module
add_rule rule@(Rule.Rule ident params _rhs) m =
    m { declarations =
            update
                (\d -> case d of
                    Rule_Declaration r' ->
                        ident == Rule.name r' &&
                        params == Rule.parameters r'
                    _ -> False)
                (Rule_Declaration rule) $
            declarations m,
        functions =
            M.insertWith
                (\_ -> update ((params ==) . Rule.parameters) rule)
                ident [rule] $
            functions m }

update :: (a -> Bool) -> a -> [a] -> [a]
update matches x xs =
    let ( pre, post ) = span ( not . matches ) xs
    in  pre ++ x : drop 1 post

make_functions ::
    [Declaration] -> M.Map Identifier [Rule]
make_functions =
    M.fromListWith (flip (++)) .
    mapMaybe (\decl ->
        case decl of
            Rule_Declaration rule -> Just (Rule.name rule, [rule])
            _ -> Nothing)


{-
We do not define the instance Input Module,
because for proper module parsing
the caller should provide the source file path and content.

instance Input Module where
  input = do
-}
parse ::
    FilePath -> String ->
    Parsec.GenParser Char () Module
parse srcLoc srcText = do
    m <- Parsec.option (Name "Main") $ do
        reserved lexer "module"
        m <- input
        void $ Parsec.optionMaybe $ parsePortList
        reserved lexer "where"
        return m
    is <- Parsec.many input
    ds <- Parsec.many input
    return $ Module {
        name = m, imports = is, declarations = ds,
        functions = make_functions ds,
        source_text = srcText,
        source_location = srcLoc }

parseUntilEOF ::
    FilePath -> String ->
    Parsec.GenParser Char () Module
parseUntilEOF srcLoc srcText = do
    m <- parse srcLoc srcText
    Parsec.eof
    return m


instance Output Module where
  output p = vcat
    [ hsep [ text "module", output $ name p, text "where" ]
    , vcat $ map output $ imports p
    , vcat $ map output $ declarations p
    ]

instance Show Module where show = render . output
-- instance Read Module where readsPrec = parsec_reader