content: 
  module Translate(translate) where
  
  import Control.Monad
  import Data.List
  import Data.Generics.PlateData
  
  import HSE
  import Type
  import Convert
  import qualified Desugar
  import Supercompile
  
  
  translate :: IO ()
  translate = do
      let parse x = fmap fromParseResult $ parseFileWithMode mode x
          mode = defaultParseMode{fixities=infixr_ 5 ["&"] ++ baseFixities}
      spec <- parse "Text/HTML/TagSoup/Specification.hs"
      impl <- parse "Text/HTML/TagSoup/Implementation.hs"
      putStrLn "Translating... "
      writeFile "TagSoup/Generate/programs/TagSoup.hs" $ regen $ mergeModules spec impl
      putStrLn "done"
  
  
  mergeModules (Module x1 x2 x3 x4 x5 x6 x7) (Module y1 y2 y3 y4 y5 y6 y7) =
      Module x1 x2 (x3++y3) Nothing Nothing (x6++y6) (x7++y7)
  
  
  types = words "String LBS BS"
  modes = replicateM 3 [False,True]
  
  showMode [pos,warn,merge] = f pos "Pos" ++ f warn "Warn" ++ f merge "Merge"
      where f b s = if b then s else ""
  
  
  {-
  optimise :: Module -> String
  optimise (Module x1 x2 x3 x4 x5 x6 x7) = unlines $
      ["{-# LANGUAGE RecordWildCards, PatternGuards, ScopedTypeVariables #-}"
      ,"module Text.HTML.TagSoup.Generated(parseTagsOptions) where"
      ,"import qualified Text.HTML.TagSoup.Manual as Manual"
      ,"import Data.Typeable"
      ,"import Data.Maybe"
      ,"import qualified Data.ByteString.Char8 as BS"
      ,"import qualified Data.ByteString.Lazy.Char8 as LBS"] ++
      map prettyPrint (nub $ filter ((/=) (ModuleName "Text.HTML.TagSoup.Implementation") . importModule) x6) ++
      ["type LBS = LBS.ByteString"
      ,"type BS = BS.ByteString"
      ,"type EntData str = str -> [Tag str]"
      ,"type EntAttrib str = (str,Bool) -> (str,[Tag str])"
      ,"patternMatchFail = error \"Pattern match fail\""
      ,"primEq x y = x == y"
      ,"primGeq x y = x >= y"
      ,"primLeq x y = x <= y"] ++
      map prettyPrint typedefs ++
      ["{-# NOINLINE parseTagsOptions #-}"
      ,"parseTagsOptions :: StringLike str => ParseOptions str -> str -> [Tag str]"] ++
      concat [
          ["parseTagsOptions opts x | Just (ParseOptions pos warn entData entAttrib merge) <- cast (opts,x) ="
          ,"    fromJust $ cast $ case (pos,warn,merge) of"] ++
          ["        ("++pb++","++wb++","++mb++") -> fp"++t++ showMode m ++ " entData entAttrib" | m <- modes, let [pb,wb,mb] = map show m]
          | t <- types] ++
      ["parseTagsOptions opts x = Manual.parseTagsOptions opts x"] ++
      concat [
          [""
          ,"{-# NOINLINE fp"++t++showMode m++ " #-}"
          ,"fp"++t++showMode m++ " :: EntData " ++ t ++ " -> EntAttrib " ++ t ++ " -> " ++ t ++ " -> [Tag " ++ t ++ "]"
          ,"fp"++t++showMode m++ " entData entAttrib x = main x"
          ,"    where"] ++
          map ("    "++) (concatMap (lines . prettyPrint) $ output $ supercompiler $ input $ mainFunc t m : decls)
          | t <- types, m <- modes, let [pb,wb,mb] = map show m]
      where
          (decls,typedefs) = partition isDecl $ desugar $ prelude ++ x7
  -}
  
  regen :: Module -> String
  regen (Module x1 x2 x3 x4 x5 x6 x7) = unlines $ concatMap (lines . prettyPrint) $ output $ input $ mainFunc t m : decls
      where (decls,typedefs) = partition isDecl $ desugar $ prelude ++ x7
            t = head types
            m = head modes
  
  
  mainFunc t [a,b,c] = fromParseResult $ parse $
      "main = \\x -> output (ParseOptions " ++ show a ++ " " ++ show b ++ " entData entAttrib " ++ show c ++ ") (parse (toString x))"
  
  prelude = map (fromParseResult . parse)
      ["id x = x"
      ,"seq x y = y"
      ,"null x = case x of z:zs -> False ; _ -> True"
      ,"not x = case x of True -> False; _ -> True"
      ,"head x = case x of z:zs -> z ; _ -> error \"head on empty\""
      ,"tail x = case x of z:zs -> zs; _ -> error \"tail on empty\""
      ,"dol x y = x y"
      ,"dot f g x = f (g x)"
      ,"opOr x y = if x then True else y"
      ,"opAnd x y = if x then y else False"
      ,"opEq x y = primEq x y"
      ,"opGeq x y = primGeq x y"
      ,"opLeq x y = primLeq x y"
      ,"opPlusPlus x y = case x of [] -> y ; z:zs -> z : opPlusPlus zs y"
      ,"opStarStarStar f g x = (f (fst x), g (snd x))"
      -- specific to String!
      ,"toString x = x"
      ]
  
  
  isDecl PatBind{} = True
  isDecl FunBind{} = True
  isDecl TypeSig{} = True
  isDecl InfixDecl{} = True
  isDecl _ = False
  
  
  ---------------------------------------------------------------------
  -- APP SPECIFIC DESUGAR
  
  desugar :: [Decl] -> [Decl]
  desugar =
      Desugar.singleCase ["S","(,)","(,,)","(,,,)"] .
      Desugar.core2 . Desugar.irrefutable . Desugar.untyped . expandOps . expandAmp . expandS .
      drop (length recordTypes) . Desugar.records . (recordTypes++)
  
  
  recordTypes = map (fromParseResult . parse)
      ["data Tag a = TagOpen a a | TagClose a | TagText a | TagComment a | TagWarning a | TagPosition a a"
      ,"data ParseOptions a = ParseOptions{optTagPosition,optTagWarning,optEntityData,optEntityAttrib,optTagTextMerge::a}"]
  
  
  -- 'c' & _ ==> ampChar
  -- v & _ ==> ampChar
  -- x@C & y ==> ampOut x y
  -- plus remove &/Outputable
  expandAmp :: [Decl] -> [Decl]
  expandAmp = transformBi f . filter (not . isAmp)
      where
          isAmp InfixDecl{} = True
          isAmp ClassDecl{} = True
          isAmp InstDecl{} = True
          isAmp _ = False
  
          f (InfixApp x op y) | prettyPrint op == "&" = Paren $ apps (var $ g x) [Paren x, Paren y]
          f x = x
  
          g Var{} = "ampChar"
          g Lit{} = "ampChar"
          g _ = "ampOut"
  
  
  -- For patterns (S v ...) => v@(S ...)
  -- For the type, loose the first field
  -- For construction, drop the first field
  expandS :: [Decl] -> [Decl]
  expandS = transformBi fRec . transformBi fPat . descendBi fExp
      where
          fExp (App (Con s) x) | prettyPrint s == "S" = Con s
          fExp x = descend fExp x
          fPat (PApp s (PVar x:xs)) | prettyPrint s == "S" = PAsPat x $ PParen $ PApp s xs
          fPat x = x
          fRec (RecDecl s (x:xs)) | prettyPrint s == "S" = RecDecl s xs
          fRec x = x
  
  
  expandOps :: [Decl] -> [Decl]
  expandOps = transformBi f
      where
          f (Symbol "$") = Ident "dol"
          f (Symbol ".") = Ident "dot"
          f (Symbol "||") = Ident "opOr"
          f (Symbol "&&") = Ident "opAnd"
          f (Symbol "==") = Ident "opEq"
          f (Symbol ">=") = Ident "opGeq"
          f (Symbol "<=") = Ident "opLeq"
          f (Symbol "++") = Ident "opPlusPlus"
          f (Symbol "***") = Ident "opStarStarStar"
          f (Symbol x) = error $ "Unknown symbol: " ++ x
          f x = x
  