{- |
    Module      :  $Header$
    Copyright   :  (c) 2008        Sebastian Fischer
                       2011 - 2015 Björn Peemöller
                       2016        Finn Teegen
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    Transform a CurrySyntax module into a string representation without any
    pretty printing.

    Behaves like a derived Show instance even on parts with a specific one.
-}
module Curry.Syntax.ShowModule (showModule) where

import Curry.Base.Ident
import Curry.Base.Position

import Curry.Syntax.Type

-- |Show a Curry module like by an devired 'Show' instance
showModule :: Show a => Module a -> String
showModule m = showsModule m "\n"

showsModule :: Show a => Module a -> ShowS
showsModule (Module ps mident espec imps decls)
  = showsString "Module "
  . showsList (\p -> showsPragma p . newline) ps . space
  . showsModuleIdent mident . newline
  . showsMaybe showsExportSpec espec . newline
  . showsList (\i -> showsImportDecl i . newline) imps
  . showsList (\d -> showsDecl d . newline) decls

showsPragma :: ModulePragma -> ShowS
showsPragma (LanguagePragma pos exts)
  = showsString "(LanguagePragma "
  . showsPosition pos . space
  . showsList showsExtension exts
  . showsString ")"
showsPragma (OptionsPragma pos mbTool args)
  = showsString "(OptionsPragma "
  . showsPosition pos . space
  . showsMaybe shows mbTool
  . shows args
  . showsString ")"

showsExtension :: Extension -> ShowS
showsExtension (KnownExtension p e)
  = showsString "(KnownExtension "
  . showsPosition p . space
  . shows e
  . showString ")"
showsExtension (UnknownExtension p s)
  = showsString "(UnknownExtension "
  . showsPosition p . space
  . shows s
  . showString ")"

showsExportSpec :: ExportSpec -> ShowS
showsExportSpec (Exporting pos exports)
  = showsString "(Exporting "
  . showsPosition pos . space
  . showsList showsExport exports
  . showsString ")"

showsExport :: Export -> ShowS
showsExport (Export qident)
  = showsString "(Export "
  . showsQualIdent qident
  . showsString ")"
showsExport (ExportTypeWith qident ids)
  = showsString "(ExportTypeWith "
  . showsQualIdent qident . space
  . showsList showsIdent ids
  . showsString ")"
showsExport (ExportTypeAll qident)
  = showsString "(ExportTypeAll "
  . showsQualIdent qident
  . showsString ")"
showsExport (ExportModule m)
  = showsString "(ExportModule "
  . showsModuleIdent m
  . showsString ")"

showsImportDecl :: ImportDecl -> ShowS
showsImportDecl (ImportDecl pos mident quali mmident mimpspec)
  = showsString "(ImportDecl "
  . showsPosition pos . space
  . showsModuleIdent mident . space
  . shows quali . space
  . showsMaybe showsModuleIdent mmident . space
  . showsMaybe showsImportSpec mimpspec
  . showsString ")"

showsImportSpec :: ImportSpec -> ShowS
showsImportSpec (Importing pos imports)
  = showsString "(Importing "
  . showsPosition pos . space
  . showsList showsImport imports
  . showsString ")"
showsImportSpec (Hiding pos imports)
  = showsString "(Hiding "
  . showsPosition pos . space
  . showsList showsImport imports
  . showsString ")"

showsImport :: Import -> ShowS
showsImport (Import ident)
  = showsString "(Import "
  . showsIdent ident
  . showsString ")"
showsImport (ImportTypeWith ident idents)
  = showsString "(ImportTypeWith "
  . showsIdent ident . space
  . showsList showsIdent idents
  . showsString ")"
showsImport (ImportTypeAll ident)
  = showsString "(ImportTypeAll "
  . showsIdent ident
  . showsString ")"

showsDecl :: Show a => Decl a -> ShowS
showsDecl (InfixDecl pos infx prec idents)
  = showsString "(InfixDecl "
  . showsPosition pos . space
  . shows infx . space
  . showsMaybe shows prec . space
  . showsList showsIdent idents
  . showsString ")"
showsDecl (DataDecl pos ident idents consdecls classes)
  = showsString "(DataDecl "
  . showsPosition pos . space
  . showsIdent ident . space
  . showsList showsIdent idents . space
  . showsList showsConsDecl consdecls . space
  . showsList showsQualIdent classes
  . showsString ")"
showsDecl (ExternalDataDecl pos ident idents)
  = showsString "(ExternalDataDecl "
  . showsPosition pos . space
  . showsIdent ident . space
  . showsList showsIdent idents
  . showsString ")"
showsDecl (NewtypeDecl pos ident idents newconsdecl classes)
  = showsString "(NewtypeDecl "
  . showsPosition pos . space
  . showsIdent ident . space
  . showsList showsIdent idents . space
  . showsNewConsDecl newconsdecl . space
  . showsList showsQualIdent classes
  . showsString ")"
showsDecl (TypeDecl pos ident idents typ)
  = showsString "(TypeDecl "
  . showsPosition pos . space
  . showsIdent ident . space
  . showsList showsIdent idents . space
  . showsTypeExpr typ
  . showsString ")"
showsDecl (TypeSig pos idents qtype)
  = showsString "(TypeSig "
  . showsPosition pos . space
  . showsList showsIdent idents . space
  . showsQualTypeExpr qtype
  . showsString ")"
showsDecl (FunctionDecl pos a ident eqs)
  = showsString "(FunctionDecl "
  . showsPosition pos . space
  . showsPrec 11 a . space
  . showsIdent ident . space
  . showsList showsEquation eqs
  . showsString ")"
showsDecl (ExternalDecl pos vars)
  = showsString "(ExternalDecl "
  . showsPosition pos . space
  . showsList showsVar vars
  . showsString ")"
showsDecl (PatternDecl pos cons rhs)
  = showsString "(PatternDecl "
  . showsPosition pos . space
  . showsConsTerm cons . space
  . showsRhs rhs
  . showsString ")"
showsDecl (FreeDecl pos vars)
  = showsString "(FreeDecl "
  . showsPosition pos . space
  . showsList showsVar vars
  . showsString ")"
showsDecl (DefaultDecl pos types)
  = showsString "(DefaultDecl "
  . showsPosition pos . space
  . showsList showsTypeExpr types
  . showsString ")"
showsDecl (ClassDecl pos context cls clsvar decls)
  = showsString "(ClassDecl "
  . showsPosition pos . space
  . showsContext context . space
  . showsIdent cls . space
  . showsIdent clsvar . space
  . showsList showsDecl decls
  . showsString ")"
showsDecl (InstanceDecl pos context qcls inst decls)
  = showsString "(InstanceDecl "
  . showsPosition pos . space
  . showsContext context . space
  . showsQualIdent qcls . space
  . showsInstanceType inst . space
  . showsList showsDecl decls
  . showsString ")"

showsContext :: Context -> ShowS
showsContext constraints
  = showsList showsConstraint constraints

showsConstraint :: Constraint -> ShowS
showsConstraint (Constraint qcls ty)
  = showsString "(Constraint "
  . showsQualIdent qcls . space
  . showsTypeExpr ty
  . showsString ")"

showsInstanceType :: InstanceType -> ShowS
showsInstanceType = showsTypeExpr

showsConsDecl :: ConstrDecl -> ShowS
showsConsDecl (ConstrDecl pos idents context ident types)
  = showsString "(ConstrDecl "
  . showsPosition pos . space
  . showsList showsIdent idents . space
  . showsContext context . space
  . showsIdent ident . space
  . showsList showsTypeExpr types
  . showsString ")"
showsConsDecl (ConOpDecl pos idents context ty1 ident ty2)
  = showsString "(ConOpDecl "
  . showsPosition pos . space
  . showsList showsIdent idents . space
  . showsContext context . space
  . showsTypeExpr ty1 . space
  . showsIdent ident . space
  . showsTypeExpr ty2
  . showsString ")"
showsConsDecl (RecordDecl pos idents context ident fs)
  = showsString "(RecordDecl "
  . showsPosition pos . space
  . showsList showsIdent idents . space
  . showsContext context . space
  . showsIdent ident . space
  . showsList showsFieldDecl fs
  . showsString ")"

showsFieldDecl :: FieldDecl -> ShowS
showsFieldDecl (FieldDecl pos labels ty)
  = showsString "(FieldDecl "
  . showsPosition pos . space
  . showsList showsIdent labels . space
  . showsTypeExpr ty
  . showsString ")"

showsNewConsDecl :: NewConstrDecl -> ShowS
showsNewConsDecl (NewConstrDecl pos ident typ)
  = showsString "(NewConstrDecl "
  . showsPosition pos . space
  . showsIdent ident . space
  . showsTypeExpr typ
  . showsString ")"
showsNewConsDecl (NewRecordDecl pos ident fld)
  = showsString "(NewRecordDecl "
  . showsPosition pos . space
  . showsIdent ident . space
  . showsPair showsIdent showsTypeExpr fld
  . showsString ")"

showsQualTypeExpr :: QualTypeExpr -> ShowS
showsQualTypeExpr (QualTypeExpr context typ)
  = showsString "(QualTypeExpr "
  . showsContext context . space
  . showsTypeExpr typ
  . showsString ")"

showsTypeExpr :: TypeExpr -> ShowS
showsTypeExpr (ConstructorType qident)
  = showsString "(ConstructorType "
  . showsQualIdent qident . space
  . showsString ")"
showsTypeExpr (ApplyType type1 type2)
  = showsString "(ApplyType "
  . showsTypeExpr type1 . space
  . showsTypeExpr type2 . space
  . showsString ")"
showsTypeExpr (VariableType ident)
  = showsString "(VariableType "
  . showsIdent ident
  . showsString ")"
showsTypeExpr (TupleType types)
  = showsString "(TupleType "
  . showsList showsTypeExpr types
  . showsString ")"
showsTypeExpr (ListType typ)
  = showsString "(ListType "
  . showsTypeExpr typ
  . showsString ")"
showsTypeExpr (ArrowType dom ran)
  = showsString "(ArrowType "
  . showsTypeExpr dom . space
  . showsTypeExpr ran
  . showsString ")"
showsTypeExpr (ParenType ty)
  = showsString "(ParenType "
  . showsTypeExpr ty
  . showsString ")"
showsTypeExpr (ForallType vars ty)
  = showsString "(ForallType "
  . showsList showsIdent vars
  . showsTypeExpr ty
  . showsString ")"

showsEquation :: Show a => Equation a -> ShowS
showsEquation (Equation pos lhs rhs)
  = showsString "(Equation "
  . showsPosition pos . space
  . showsLhs lhs . space
  . showsRhs rhs
  . showsString ")"

showsLhs :: Show a => Lhs a -> ShowS
showsLhs (FunLhs ident conss)
  = showsString "(FunLhs "
  . showsIdent ident . space
  . showsList showsConsTerm conss
  . showsString ")"
showsLhs (OpLhs cons1 ident cons2)
  = showsString "(OpLhs "
  . showsConsTerm cons1 . space
  . showsIdent ident . space
  . showsConsTerm cons2
  . showsString ")"
showsLhs (ApLhs lhs conss)
  = showsString "(ApLhs "
  . showsLhs lhs . space
  . showsList showsConsTerm conss
  . showsString ")"

showsRhs :: Show a => Rhs a -> ShowS
showsRhs (SimpleRhs pos expr decls)
  = showsString "(SimpleRhs "
  . showsPosition pos . space
  . showsExpression expr . space
  . showsList showsDecl decls
  . showsString ")"
showsRhs (GuardedRhs cexps decls)
  = showsString "(GuardedRhs "
  . showsList showsCondExpr cexps . space
  . showsList showsDecl decls
  . showsString ")"

showsCondExpr :: Show a => CondExpr a -> ShowS
showsCondExpr (CondExpr pos exp1 exp2)
  = showsString "(CondExpr "
  . showsPosition pos . space
  . showsExpression exp1 . space
  . showsExpression exp2
  . showsString ")"

showsLiteral :: Literal -> ShowS
showsLiteral (Char c)
  = showsString "(Char "
  . shows c
  . showsString ")"
showsLiteral (Int n)
  = showsString "(Int "
  . shows n
  . showsString ")"
showsLiteral (Float x)
  = showsString "(Float "
  . shows x
  . showsString ")"
showsLiteral (String s)
  = showsString "(String "
  . shows s
  . showsString ")"

showsConsTerm :: Show a => Pattern a -> ShowS
showsConsTerm (LiteralPattern a lit)
  = showsString "(LiteralPattern "
  . showsPrec 11 a . space
  . showsLiteral lit
  . showsString ")"
showsConsTerm (NegativePattern a lit)
  = showsString "(NegativePattern "
  . showsPrec 11 a . space
  . showsLiteral lit
  . showsString ")"
showsConsTerm (VariablePattern a ident)
  = showsString "(VariablePattern "
  . showsPrec 11 a . space
  . showsIdent ident
  . showsString ")"
showsConsTerm (ConstructorPattern a qident conss)
  = showsString "(ConstructorPattern "
  . showsPrec 11 a . space
  . showsQualIdent qident . space
  . showsList showsConsTerm conss
  . showsString ")"
showsConsTerm (InfixPattern a cons1 qident cons2)
  = showsString "(InfixPattern "
  . showsPrec 11 a . space
  . showsConsTerm cons1 . space
  . showsQualIdent qident . space
  . showsConsTerm cons2
  . showsString ")"
showsConsTerm (ParenPattern cons)
  = showsString "(ParenPattern "
  . showsConsTerm cons
  . showsString ")"
showsConsTerm (TuplePattern conss)
  = showsString "(TuplePattern "
  . showsList showsConsTerm conss
  . showsString ")"
showsConsTerm (ListPattern a conss)
  = showsString "(ListPattern "
  . showsPrec 11 a . space
  . showsList showsConsTerm conss
  . showsString ")"
showsConsTerm (AsPattern ident cons)
  = showsString "(AsPattern "
  . showsIdent ident . space
  . showsConsTerm cons
  . showsString ")"
showsConsTerm (LazyPattern cons)
  = showsString "(LazyPattern "
  . showsConsTerm cons
  . showsString ")"
showsConsTerm (FunctionPattern a qident conss)
  = showsString "(FunctionPattern "
  . showsPrec 11 a . space
  . showsQualIdent qident . space
  . showsList showsConsTerm conss
  . showsString ")"
showsConsTerm (InfixFuncPattern a cons1 qident cons2)
  = showsString "(InfixFuncPattern "
  . showsPrec 11 a . space
  . showsConsTerm cons1 . space
  . showsQualIdent qident . space
  . showsConsTerm cons2
  . showsString ")"
showsConsTerm (RecordPattern a qident cfields)
  = showsString "(RecordPattern "
  . showsPrec 11 a . space
  . showsQualIdent qident . space
  . showsList (showsField showsConsTerm) cfields . space
  . showsString ")"

showsExpression :: Show a => Expression a -> ShowS
showsExpression (Literal a lit)
  = showsString "(Literal "
  . showsPrec 11 a . space
  . showsLiteral lit
  . showsString ")"
showsExpression (Variable a qident)
  = showsString "(Variable "
  . showsPrec 11 a . space
  . showsQualIdent qident
  . showsString ")"
showsExpression (Constructor a qident)
  = showsString "(Constructor "
  . showsPrec 11 a . space
  . showsQualIdent qident
  . showsString ")"
showsExpression (Paren expr)
  = showsString "(Paren "
  . showsExpression expr
  . showsString ")"
showsExpression (Typed expr qtype)
  = showsString "(Typed "
  . showsExpression expr . space
  . showsQualTypeExpr qtype
  . showsString ")"
showsExpression (Tuple exps)
  = showsString "(Tuple "
  . showsList showsExpression exps
  . showsString ")"
showsExpression (List a exps)
  = showsString "(List "
  . showsPrec 11 a . space
  . showsList showsExpression exps
  . showsString ")"
showsExpression (ListCompr expr stmts)
  = showsString "(ListCompr "
  . showsExpression expr . space
  . showsList showsStatement stmts
  . showsString ")"
showsExpression (EnumFrom expr)
  = showsString "(EnumFrom "
  . showsExpression expr
  . showsString ")"
showsExpression (EnumFromThen exp1 exp2)
  = showsString "(EnumFromThen "
  . showsExpression exp1 . space
  . showsExpression exp2
  . showsString ")"
showsExpression (EnumFromTo exp1 exp2)
  = showsString "(EnumFromTo "
  . showsExpression exp1 . space
  . showsExpression exp2
  . showsString ")"
showsExpression (EnumFromThenTo exp1 exp2 exp3)
  = showsString "(EnumFromThenTo "
  . showsExpression exp1 . space
  . showsExpression exp2 . space
  . showsExpression exp3
  . showsString ")"
showsExpression (UnaryMinus expr)
  = showsString "(UnaryMinus "
  . showsExpression expr
  . showsString ")"
showsExpression (Apply exp1 exp2)
  = showsString "(Apply "
  . showsExpression exp1 . space
  . showsExpression exp2
  . showsString ")"
showsExpression (InfixApply exp1 op exp2)
  = showsString "(InfixApply "
  . showsExpression exp1 . space
  . showsInfixOp op . space
  . showsExpression exp2
  . showsString ")"
showsExpression (LeftSection expr op)
  = showsString "(LeftSection "
  . showsExpression expr . space
  . showsInfixOp op
  . showsString ")"
showsExpression (RightSection op expr)
  = showsString "(RightSection "
  . showsInfixOp op . space
  . showsExpression expr
  . showsString ")"
showsExpression (Lambda conss expr)
  = showsString "(Lambda "
  . showsList showsConsTerm conss . space
  . showsExpression expr
  . showsString ")"
showsExpression (Let decls expr)
  = showsString "(Let "
  . showsList showsDecl decls . space
  . showsExpression expr
  . showsString ")"
showsExpression (Do stmts expr)
  = showsString "(Do "
  . showsList showsStatement stmts . space
  . showsExpression expr
  . showsString ")"
showsExpression (IfThenElse exp1 exp2 exp3)
  = showsString "(IfThenElse "
  . showsExpression exp1 . space
  . showsExpression exp2 . space
  . showsExpression exp3
  . showsString ")"
showsExpression (Case ct expr alts)
  = showsString "(Case "
  . showsCaseType ct . space
  . showsExpression expr . space
  . showsList showsAlt alts
  . showsString ")"
showsExpression (RecordUpdate expr efields)
  = showsString "(RecordUpdate "
  . showsExpression expr . space
  . showsList (showsField showsExpression) efields
  . showsString ")"
showsExpression (Record a qident efields)
  = showsString "(Record "
  . showsPrec 11 a . space
  . showsQualIdent qident . space
  . showsList (showsField showsExpression) efields
  . showsString ")"

showsInfixOp :: Show a => InfixOp a -> ShowS
showsInfixOp (InfixOp a qident)
  = showsString "(InfixOp "
  . showsPrec 11 a . space
  . showsQualIdent qident
  . showsString ")"
showsInfixOp (InfixConstr a qident)
  = showsString "(InfixConstr "
  . showsPrec 11 a . space
  . showsQualIdent qident
  . showsString ")"

showsStatement :: Show a => Statement a -> ShowS
showsStatement (StmtExpr expr)
  = showsString "(StmtExpr "
  . showsExpression expr
  . showsString ")"
showsStatement (StmtDecl decls)
  = showsString "(StmtDecl "
  . showsList showsDecl decls
  . showsString ")"
showsStatement (StmtBind cons expr)
  = showsString "(StmtBind "
  . showsConsTerm cons . space
  . showsExpression expr
  . showsString ")"

showsCaseType :: CaseType -> ShowS
showsCaseType Rigid = showsString "Rigid"
showsCaseType Flex  = showsString "Flex"

showsAlt :: Show a => Alt a -> ShowS
showsAlt (Alt pos cons rhs)
  = showsString "(Alt "
  . showsPosition pos . space
  . showsConsTerm cons . space
  . showsRhs rhs
  . showsString ")"

showsField :: (a -> ShowS) -> Field a -> ShowS
showsField sa (Field pos ident a)
  = showsString "(Field "
  . showsPosition pos . space
  . showsQualIdent ident . space
  . sa a
  . showsString ")"

showsVar :: Show a => Var a -> ShowS
showsVar (Var a ident)
  = showsString "(Var "
  . showsPrec 11 a . space
  . showsIdent ident
  . showsString ")"

showsPosition :: Position -> ShowS
showsPosition Position { line = l, column = c } = showsPair shows shows (l, c)
showsPosition _ = showsString "(0,0)"
-- showsPosition (Position file row col)
--   = showsString "(Position "
--   . shows file . space
--   . shows row . space
--   . shows col
--   . showsString ")"

showsString :: String -> ShowS
showsString = (++)

space :: ShowS
space = showsString " "

newline :: ShowS
newline = showsString "\n"

showsMaybe :: (a -> ShowS) -> Maybe a -> ShowS
showsMaybe shs = maybe (showsString "Nothing")
                       (\x -> showsString "(Just " . shs x . showsString ")")

showsList :: (a -> ShowS) -> [a] -> ShowS
showsList _   [] = showsString "[]"
showsList shs (x:xs)
  = showsString "["
  . foldl (\sys y -> sys . showsString "," . shs y) (shs x) xs
  . showsString "]"

showsPair :: (a -> ShowS) -> (b -> ShowS) -> (a,b) -> ShowS
showsPair sa sb (a,b)
  = showsString "(" . sa a . showsString "," . sb b . showsString ")"

showsIdent :: Ident -> ShowS
showsIdent (Ident p x n)
  = showsString "(Ident " . showsPosition p . space
  . shows x . space . shows n . showsString ")"

showsQualIdent :: QualIdent -> ShowS
showsQualIdent (QualIdent mident ident)
  = showsString "(QualIdent "
  . showsMaybe showsModuleIdent mident
  . space
  . showsIdent ident
  . showsString ")"

showsModuleIdent :: ModuleIdent -> ShowS
showsModuleIdent (ModuleIdent pos ss)
  = showsString "(ModuleIdent "
  . showsPosition pos . space
  . showsList (showsQuotes showsString) ss
  . showsString ")"

showsQuotes :: (a -> ShowS) -> a -> ShowS
showsQuotes sa a
  = showsString "\"" . sa a . showsString "\""