-- Hey Emacs, this is (partly) -*- Haskell -*-
{ 
module Parser(parseHDoc, ParsedHDoc) where

import Scanner
import HDocDefs
import HsSyn
import Alex

import List  (intersperse)
import Maybe (Maybe(..), listToMaybe, maybeToList)
import Monad (liftM)
}

%name hDocParser DocStart
%monad { (Either String) } { thenE } { Right }
%tokentype { Token }

%token
	'begin'	   { BeginHDoc $$ _  }
	'end'	   { EndHDoc  _ _   }

        'beginCons' { BeginHDocCons $$ _ }

	'@param'   { AtParam _ _    }
	'@return'  { AtReturn _ _   }
	'@monadic' { AtMonadic _ _  }
	'@cons'    { AtCons _ _     }
        '::'       { HasType _ _    }
	'=>'       { Implies _ _    }
	'->'       { Arrow _ _      }
	','        { Comma _ _      }
        '('        { OParen _ _     }
        ')'        { CParen _ _     }
        '['        { OBracket _ _   }
        ']'        { CBracket _ _   }
        '{'        { OBrace   _ _   }
        '}'        { CBrace   _ _   }
        ident      { Ident _ _ $$    }
        conid      { Conid _ _ $$    }

	'text'     { SText    _ _ $$ }
	'<tag>'    { $$@(BeginTag _ _ _) }
	'</tag>'   { $$@(EndTag   _ _ _) }
	tagAttr    { TagAttr      _ _ $$ }
	tagEq      { TagAttrEq    _ _    }
	tagAttrVal { TagAttrValue _ _ $$ }
	'<br/>'    { SBr _ _        }
	'&...;'    { SUnicode _ _ $$ }
	white      { SWhiteSpace _ _ }

        '@author'  { AtAuthor  _ _   }
	'@version' { AtVersion _ _   }
        '@see...'  { AtSee _ _ $$    }
	'@doc...'  { AtDoc _ _ $$    }

%%

DocStart :: { ParsedHDoc }
	 : docs    {% Right $1 }

docs : {- empty -} { \md -> [] }
     | doc docs    { \md -> $1 md : $2 md }

doc  :: { ModuleDoc -> CommentAssoc }
     : 'beginCons' hdoctext 'end'
       { let gt = GenT { gtDescription=$2, gtSee=[] }
	 in  \md -> Positional (HDocConsLoc (sl $1) [HDoc gt ConstructorTags])
       }
     | startHDoc hdoctext see 'end'
       { let gt = GenT { gtDescription = $2, gtSee = $3 }
	 in  \md -> $1 [HDoc gt (ModuleTags $
				 MT {mtAuthor = [], mtVersion = [] }),
			HDoc gt (FunctionTags $
				 FT {ftParam = [],ftReturn = Nothing}),
			HDoc gt (DataTags $ DT {dtCons = []}),
			HDoc gt TypeTags, HDoc gt ClassInstTags]
       }
     | startHDoc hdoctext consdef see 'end'
       { let gt = GenT { gtDescription = $2, gtSee = $4 }
	 in  \md -> $1 [HDoc gt (DataTags $ DT {dtCons = $3 md})]
       }
     | startHDoc hdoctext paramsdef see 'end'
       { let gt = GenT { gtDescription = $2, gtSee = $4 }
	 in  \md -> $1 [HDoc gt (FunctionTags $FT { ftParam = $3 md,
						    ftReturn = Nothing })]
       }
     | startHDoc hdoctext retdef see 'end'
       { let gt = GenT { gtDescription = $2, gtSee = $4 }
	 in  \md -> $1 [HDoc gt (FunctionTags $ FT { ftParam = [],
						     ftReturn = $3 md })]
       }
     | startHDoc hdoctext paramsdef retdef see 'end'
       { let gt = GenT { gtDescription = $2, gtSee = $5 }
	 in  \md -> $1 [HDoc gt (FunctionTags $ FT { ftParam = $3 md,
						     ftReturn = $4 md })]
       }
     | startHDoc hdoctext auver see 'end'
       { let { gt = GenT { gtDescription = $2, gtSee = $4 }; (au, ver) = $3 }
	 in  \md -> $1 [HDoc gt (ModuleTags $
				 MT {mtAuthor = au, mtVersion = ver })]
       }

startHDoc :: { [HDoc] -> CommentAssoc }
	  : 'begin'            { \hds -> Positional (HDocLoc (sl $1) hds)     }
	  | 'begin' '@doc...'  { \hds -> PerName    (hsQNameFromString $2) hds }

auver : '@author'  hdoctext { ($2, []) }
      | '@version' hdoctext { ([], $2) }
      | '@author'  hdoctext '@version' hdoctext { ($2, $4) }
      | '@version' hdoctext '@author'  hdoctext { ($4, $2) }

see : {- empty -}   { [] }
    | see '@see...' { $1 ++ [$2] }

consdef : consdef1          { \md -> [$1 md] }
	| consdef1 consdef  { \md -> $1 md : $2 md }

consdef1 : '@cons' conid hdoctext
	     { \md -> ConstructorDoc (Constructor $2 [] Nothing [] []) $3 }
	 | '@cons' conid typeds hdoctext
	     { 
	       \md ->
	       let ty = $3 md
	       in ConstructorDoc (Constructor $2 [] Nothing ty (map extractType ty)) $4
	     }
	 | '@cons' conid '{' typedlist '}' hdoctext
	     { \md -> ConstructorDoc (Labelled $2 ($4 md)) $6 }  

paramsdef : '@param' typed hdoctext            { \md -> [($2 md, $3)] }
          | '@param' typed hdoctext paramsdef  { \md -> ($2 md,$3) : $4 md }

retdef : '@return' hdoctext        { \md -> Just (Nothing,     $2,Functional) }
       | '@return' typed hdoctext  { \md -> Just (Just ($2 md),$3,Functional) }
       | '@monadic' hdoctext       { \md -> Just (Nothing,     $2,Monadic) }
       | '@monadic' typed hdoctext { \md -> Just (Just ($2 md),$3,Monadic) } 


ctype : type             { \md -> $1 md }
      | type '=>' type   { \md -> Context ($1 md) ($3 md) }

type : stype             { \md -> $1 md }
     | stype '->' type   { \md -> Fun ($1 md) ($3 md) }

stype : conid types
	  { \md -> Con (lookupTypeId md (hsQNameFromString $1)) ($2 md) }
      | sstype           { \md -> $1 md }

sstype : '[' type ']'     { \md -> List ($2 md) }
       | '(' typelist ')' { \md ->
			    let tl = $2 md
			    in if length tl == 1
			         then head tl
			         else Tuple tl }
       | ident       { \md -> Simple (lookupTypeId md (hsQNameFromString $1)) }
       | conid       { \md -> Simple (lookupTypeId md (hsQNameFromString $1)) }

types : sstype           { \md -> [$1 md] }
      | sstype types     { \md -> ($1 md) : ($2 md) }

typelist : {- empty -}        { \md -> [] }
	 | type               { \md -> [$1 md] }
	 | type ',' typelist  { \md -> $1 md : $3 md }


typed : typed2                   { $1 }
      | typed2 '::' ctype        { \md -> Typed ($1 md) ($3 md) }

typed2 : styped                      { $1 }
       | styped '->' typed2          { \md -> FunT ($1 md) ($3 md) }
       | styped '=>' typed2          { \md -> ContextT ($1 md) ($3 md) }

styped : conid typeds          { \md -> ConT $1 ($2 md) }
       | sstyped               { $1 }

sstyped : conid                { \md -> SimpleT $1 }
        | ident                { \md -> SimpleT $1 }
	| '[' typed ']'        { \md -> ListT   ($2 md) }
	| '(' typedlist ')'    { \md ->
				 let tl = $2 md
				 in if length tl == 1
				      then head tl
				      else TupleT tl }

typeds : sstyped         { \md -> [$1 md] }
       | sstyped typeds  { \md -> $1 md : $2 md }

typedlist : {- empty -}          { \md -> [] }
	  | typed                { \md -> [$1 md] }
	  | typed ',' typedlist  { \md -> $1 md : $3 md }


hdoctext :: { HDocText }
	 : whitespace hdt  { $2 }
	 | hdt             { $1 }

hdt :: { HDocText }
     : {- empty -}            { [] }
     | hdt hdocel whitespace  { $1 ++ [$2,$3] }
     | hdt hdocel             { $1 ++ [$2]    }

hdocel : 'text'                       { HdeText $1 }
       | '&...;'                      { HdeUnicode $1      }
       | '<br/>'                      { HdeTag1 BrTag      }
       | '<tag>' tagAttrs hdoctext '</tag>'
	 {% let { BeginTag p1 inp1 t1 = $1; EndTag p2 inp2 t2 = $4;
		  Pn _ l1 _ = p1; Pn _ l2 _ = p2 }
	    in if t1 == t2
	         then Right (HdeTag2 t1 $2 $3)
	         else Left ("tag <" ++ nameOfTag t1 ++ "> in line " ++
			    show l1 ++ " is closed by </" ++ nameOfTag t2 ++
			    "> in line " ++ show l2) 
	 }

tagAttrs :: { [TagAttr] }
	  : {- empty -}       { [] }
	  | tagAttrs tagAttr tagEq tagAttrVal
	    {% case attrToTagAttr $2 $4 of
	           Right ta  -> Right ($1 ++ [ta])
	           Left  err -> Left  err
	    }

whitespace : white             { HdeWhiteSpace }
	   | whitespace white  { HdeWhiteSpace }

{
thenE :: Either String a -> (a -> Either String b) -> Either String b
thenE (Right x) f = f x
thenE (Left  y) _ = Left y

sl :: Posn -> SrcLoc
sl (Pn _ y x) = SrcLoc y x
		
happyError :: [Token] -> Either String a
happyError   []   = Left "parse error: not enough tokens\n"
happyError (t:ts) = Left ("parse error in line " ++ show l ++ " before\n"
			  ++ take 80 (remainingInput t))
    where
    Pn _ l _ = pos t
	       

type ParsedHDoc = ModuleDoc -> [CommentAssoc]

parseHDoc :: String -> Either String ParsedHDoc
parseHDoc input =
    case scanError of
		   "" -> hDocParser scanned
		   se -> Left se
    where
    scanned = tokens input
    scanError = concat $ intersperse "\n" [e | ScanError e <- scanned]

emptyMod :: ModuleDoc
emptyMod = ModuleDoc { moduleName = "empty test module",
		       descriptionM = [],
		       authorM = [],
		       versionM =[],
		       seeTagsM = [],
		       exports = [],
		       imports = [],
		       functions = [],
		       datatypes = [],
		       classes   = [],
		       instances = [],
		       typesynonyms = [],
		       appearsM = True,
		       hiddenM = False
		     }

}