module Module (
    Name (Name, deconsName), tellName, mainName, noName,
    Source (..), maybeEditor,
    Identifier (Identifier, deconsIdentifier),
    stripIdentifier,

    Module,
    name,
    version,
    sourceText,
    sourceLocation,
    constructors,
    controls,
    functions,
    imports,
    source,

    FunctionDeclarations,
    ConstructorDeclarations,

    Version(Version),
    noVersion,
    initVersion,
    nextVersion,
    equalVersion,

    empty,
    addRule,

    nameFromIdentifier,
    makeFileName,
    parse,
    ) where

import ModuleBase ( Name(Name, deconsName), tellName, mainName, noName,
                    Version(Version),
                    noVersion, initVersion, nextVersion, equalVersion,
                    Source(File, Editor), maybeEditor, formatSource )
import InOut ( Input, Output, input, output )
import Term ( Term )
import TermParser ( lexer )
import Rule ( Rule )
import SourceText
            ( ModuleRange, Range,
              extractModuleName, extractModuleRange, setRangeSourceName )
import qualified ControllerBase as Controller
import qualified Type
import qualified Term
import qualified Rule

import qualified Exception
import qualified Control.Monad.Exception.Synchronous as ME

import qualified Data.Map as Map
import Data.Map ( Map )
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 qualified Text.PrettyPrint.HughesPJ as Pretty
import Text.PrettyPrint.HughesPJ
           ( (<+>), ($$), hsep, sep, hang, punctuate,
             render, text, comma, vcat, parens )
import qualified Data.Char as Char

import qualified System.Path as Path
import Data.List.HT ( chop )
import Data.Eq.HT ( equating )

import Control.Applicative ( (<$>) )
import Control.Functor.HT ( void )



indent :: Int
indent = 4

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

parsePortList :: Parsec.Parser [Term.Identifier Range]
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 Pretty.empty
                    , output $ source i
                    , case rename i of
                        Nothing -> Pretty.empty
                        Just r  -> text "as" <+> output r
                    ]


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

parseIdentList :: Parsec.CharParser () [Term.Identifier Range]
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 "::")
            indent
            (sep
                [if null context
                   then Pretty.empty
                   else parens ( hsep ( punctuate ( text "," ) $
                                 map output context ) ) <+> text "=>",
                 output typeExpr <+> text ";"])


data Data = Data { dataLhs :: Term Range
                 , dataRhs :: [ Term Range ]
                 }
    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 Range
                 , typeRhs :: Term Range
                 }
    deriving (Show)

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

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


data Infix = Infix Assoc Int [ Term.Identifier Range ]

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 ))
                indent
                (hsep ( punctuate comma $ map output idents ) <+> text ";")


data Declaration = TypeSignature TypeSig
                 | RuleDeclaration (Rule Range)
                 | TypeDeclaration Type
                 | DataDeclaration Data
                 | InfixDeclaration Infix
    deriving (Show)

instance Input Declaration where
    input = fmap DataDeclaration input
        <|> fmap InfixDeclaration input
        <|> fmap TypeDeclaration input
        <|> fmap TypeSignature (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 RuleDeclaration input

instance Output Declaration where
    output decl = case decl of
        TypeSignature d -> output d
        DataDeclaration d -> output d
        TypeDeclaration d -> output d
        RuleDeclaration d -> output d
        InfixDeclaration 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 sourceLocation (defined here)

data Module =
    Module
        { name :: Name
        , version :: Maybe Version
        , imports :: [ Import ]
        , declarations :: [ Declaration ]
        , functions :: FunctionDeclarations
        , constructors :: ConstructorDeclarations
        , controls :: Controller.Assignments
        , sourceText :: String
        , sourceLocation :: Path.AbsFile
        }

nameFromIdentifier :: Term.Identifier ModuleRange -> Name
nameFromIdentifier = extractModuleName . Term.range

makeFileName :: Name -> Path.RelFile
makeFileName (Name n) =
    Path.addExtension (Path.joinPath $ chop ('.'==) n) "hs"


newtype Identifier = Identifier { deconsIdentifier :: String }
    deriving (Eq, Ord)

stripIdentifier :: Term.Identifier range -> Identifier
stripIdentifier = Identifier . Term.name

type FunctionDeclarations =
        Map Identifier (Term.Identifier ModuleRange, [Rule ModuleRange])
type ConstructorDeclarations =
        Map Identifier (Term.Identifier ModuleRange)


empty :: Name -> Module
empty moduleName =
    Module {
        name = moduleName,
        version = noVersion,
        imports = [],
        sourceText = show $ outputModuleHead moduleName,
        sourceLocation = Path.file "/dev/null",
        functions = Map.empty,
        constructors = Map.empty,
        controls = Map.empty,
        declarations = []
    }

-- | add, or replace (if rule with exact same lhs is already present)
addRule :: Rule ModuleRange -> Module -> Module
addRule rule@(Rule.Rule ident params _rhs) m =
  let matchParams ps = Term.equatingList Term.match ps . Rule.parameters
  in
    m { declarations =
            revUpdate
                (\d -> case d of
                    RuleDeclaration r' ->
                        equating Term.name (extractModuleRange <$> ident) (Rule.name r') &&
                        matchParams (map (fmap extractModuleRange) params) r'
                    _ -> False)
                (RuleDeclaration (extractModuleRange <$> rule)) $
            declarations m,
        functions =
            Map.insertWith
                (\_ -> (,) ident . revUpdate (matchParams params) rule . snd)
                (stripIdentifier ident) (ident, [rule]) $
            functions m }

{- |
replace a matching element if it exists
and append the new element otherwise.
-}
update :: (a -> Bool) -> a -> [a] -> [a]
update matches x xs =
    let ( pre, post ) = break matches xs
    in  pre ++ x : drop 1 post

{- |
replace a matching element if it exists
and prepend the new element otherwise.
-}
revUpdate :: (a -> Bool) -> a -> [a] -> [a]
revUpdate p x = reverse . update p x . reverse

makeFunctions :: Name -> Version -> [Declaration] -> FunctionDeclarations
makeFunctions srcName vers =
    Map.fromListWith (\(nm,xs) (_,ys) -> (nm, ys++xs)) .
    mapMaybe (\decl ->
        case decl of
            RuleDeclaration rule -> Just $
                let nm = Rule.name rule
                in  (stripIdentifier nm,
                     (setRangeSourceName srcName vers <$> nm,
                      [setRangeSourceName srcName vers <$> rule]))
            _ -> Nothing)

makeConstructors :: Name -> Version -> [Declaration] -> ConstructorDeclarations
makeConstructors srcName vers decls = Map.fromList $ do
    DataDeclaration (Data {dataRhs = summands}) <- decls
    Term.Node ident _ <- summands
    return (stripIdentifier ident, setRangeSourceName srcName vers <$> ident)

makeControllers ::
    Name -> Version -> [Declaration] -> Exception.Monad Controller.Assignments
makeControllers srcName vers decls =
    flip (foldr
        (\r go a -> Controller.collect r >>= Controller.union a >>= go)
        return) Map.empty $ do
    Module.RuleDeclaration rule <- decls
    return $ setRangeSourceName srcName vers <$> Rule.rhs rule

{- |
Replace source names in all identifiers.
We can only do this after parsing
because if a parse error happens, module renaming will be skipped
and thus parse errors must refer
to the old module name or to the file name.
-}
fromDeclarations ::
    Path.AbsFile -> String ->
    Name -> Version -> [Import] -> [Declaration] ->
    Controller.Assignments -> Module
fromDeclarations srcLoc srcText moduleName vers imps decls ctrls =
    Module {
        name = moduleName,
        version = Just vers,
        imports = imps,
        declarations = decls,
        functions = makeFunctions moduleName vers decls,
        constructors = makeConstructors moduleName vers decls,
        controls = ctrls,
        sourceText = srcText,
        sourceLocation = srcLoc
    }

{-
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
-}
parser :: Parsec.Parser (Name, [Import], [Declaration])
parser = do
    m <- Parsec.option mainName $ do
        reserved lexer "module"
        m <- input
        void $ Parsec.optionMaybe parsePortList
        reserved lexer "where"
        return m
    is <- Parsec.many input
    ds <- Parsec.many input
    Parsec.eof
    return (m,is,ds)

parse ::
    Version -> Maybe Name -> Path.AbsFile -> String -> Exception.Monad Module
parse vers srcName srcLoc srcText =
    let src = maybe (File srcLoc) Editor srcName
    in  either
            (ME.Exception . Exception.messageFromParserError src)
            (\(m,is,ds) ->
                fromDeclarations srcLoc srcText m vers is ds
                    <$> makeControllers m vers ds) $
        Parsec.parse parser (formatSource src) srcText



outputModuleHead :: Name -> Pretty.Doc
outputModuleHead nm =
    hsep [ text "module", output nm, text "where" ]

instance Output Module where
  output p = vcat
    [ outputModuleHead (name p)
    , vcat $ map output $ imports p
    , vcat $ map output $ declarations p
    ]

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