module DetMachineToHaskell2(dfaToHaskell,CaseOf(..),OutputFun(..)) where
import PPrint
import HaskellChars
import HsTokens
import List(partition,sort,sortBy,nub)
import DFA(DFA(..))
import qualified OrdMap as OM
import OpTypes(cmpBy)
import MUtils(collectBySnd)
import Trace(trace)

dfaToHaskell charclasses modname imports funname ((init,final),DFA dfa) =
    "module" & modname & "("!funname!")" & "where" & nl &
    vmap ("import"&) imports & nl &
    "type" & "Output" & "=" & "[(Token,String)]" & nl &
    "type" & "Input" & "=" & "String" & nl &
    "type" & "Acc"  & "=" & "Input" & "-- reversed" & nl &
    "type" & "Lexer"  & "=" & "Input -> Output" & nl &
    "type" & "LexerState"  & "=" & "(Acc->Lexer) -> Acc -> Lexer" & nl &
    nl &
    funname & "::" & "Lexer" & nl &
    funname & "is" & "=" & start init "is" & nl &
    nl &
    charclassfundef &
    statesToHaskell final charclassfun dfa
  where
    (charclassfundef,charclassfun) =
      case charclasses::(Maybe [(HaskellChar,Int)]) of
        Nothing -> (nil,id)
	Just ccs -> (charClassFunToHaskell ccs & nl,("cclass" &))

charClassFunToHaskell ccs =
    "cclass" & "::" & "Char" & "->" & "Int" & nl &
    "cclass" & "c" & "=" & nl &
    indented (haskellCharCase "c" show "0" ccs) & nl

state st = "state"!st
scall st err acc is = state st & err & acc & is -- state function call
lhs st is = scall st "err" "as" is -- lhs of state function

startstate st = "start"!st
start st is = startstate st & is -- (re)start from state 
startlhs st is = start st is -- lhs of state start function

statesToHaskell final ccfun dfa =
    vmap (stateToHaskell final (ccfun,alphabet)) states
  where
    states = OM.toList dfa
    alphabet =
      case errorValue of
	Just e ->  Just (e:nub [c|(_,(iedges,_))<-states,(c,_)<-iedges])
	Nothing -> Nothing

stateToHaskell final ccinfo ste@(st,(_,oedges)) =
    startdef &
    state st & "::" & "LexerState" & nl &
    stateToHaskell'' final ccinfo ste
  where
    -- If there are output edges, this state can't be a start state.
    startdef =
      if null oedges
      then startstate st & "::" & "Lexer" & nl &
           startlhs st "is" & "=" & scall st err (show "") "is" & nl
      else nil

    err = "("!"\\"&"as"&"is"&"->"&oedgesToHaskell "is" oedges !")"

stateToHaskell'' final ccinfo (st,([],oedges@(_:_))) =
  lhs st "is" & "=" & indented (oedgesToHaskell "is" oedges) & nl
stateToHaskell'' final ccinfo (st,es@(_,oedges)) =
  lhs st "[]" & "=" & indented (eofEdge st final oedges) & nl &
  lhs st "iis@(i:is)" & "=" &
  stateToHaskell' ccinfo es & nl

eofEdge st final []     | st `elem` final = "gotEOF" & "as"
eofEdge _  _     oedges                   =
    opterrfun oedges "[]" ("err"&"as"&"[]")
    --oedgesToHaskell "[]" oedges

stateToHaskell' ccinfo ([],    oedges) = oedgesToHaskell "iis" oedges
stateToHaskell' (ccfun,Just allClasses) (iedges@(_:_),oedges) =
  nl &
  indented (opterrfun oedges "iis"(
    caseExp (ccfun (pr"i"))
            opt_iedgeToHaskell'
	    (opt_iedgeToHaskell' iedge')
	    iedges''))
  where
    (_,iedge'):iedges' = sortBy order $
			 collectBySnd [(c,lookup c iedges)|c<-allClasses]
    order = cmpBy (negate.length.fst)
    iedges'' = [(c,st)|(cs,st)<-iedges',c<-cs]

    opt_iedgeToHaskell' = maybe ("err"&"as"&"iis") iedgeToHaskell'

stateToHaskell' (ccfun,Nothing) (iedges,oedges) =
  nl &
  indented (opterrfun oedges "iis"(
    caseExp (ccfun (pr"i"))
            iedgeToHaskell'
	    ("err"&"as"&"iis") -- (oedgesToHaskell "iis" oedges)
	    iedges))

opterrfun oedges iis body =
    if null oedges
    then body
    else body&nl&"where"&"err"&"_ _"&"="&oedgesToHaskell iis oedges
{-
    else "let"&"err"&"_ _"&"="&oedgesToHaskell iis oedges & nl &
	  "in"&body
-}
--iedgesToHaskell = vpr . map iedgeToHaskell
--iedgeToHaskell (c,st) = show c & "->" & iedgeToHaskell' st

iedgeToHaskell' st = scall st "err" "(i:as)" "is"

oedgesToHaskell is = oedgesToHaskell' "as" is
oedgesToHaskell' as is [] = "gotError" & as & is
oedgesToHaskell' as is [oedge] = oedgeToHaskell as is oedge
oedgesToHaskell' as is oedges0 =
  trace msg $
  oedgeToHaskell as is oedge
  -- & nl & "--" & msg
  where
    -- On ambiguities, make a choice by comparing token classes:
    oedges = sort oedges0
    oedge = last oedges -- give priority to later tokens in the token data type
    msg = "Machine is nondeterministic: "++show oedges
oedgeToHaskell as is (os,st) =
-- "("!show os!","&"reverse"&"as"!")"&":"&state st & show "" & is
  output os (pr as) (pr st) (pr is)


--

class Show token => OutputFun token where
  output :: token -> Document -> Document -> Document -> Document

  output = default_output

default_output token as next is =
  "output" & show token & as & "("!startstate next & is !")"

instance OutputFun Token where
  output token as next is =
    case token of
      NestedCommentStart -> "nestedComment" & as & is & state next
      _ -> default_output token as next is

class CaseOf a where
  caseExp :: (Printable exp,Printable rhs) =>
             exp -> (v->rhs) -> rhs -> [(a,v)] -> Document
  errorValue :: Maybe a
  errorValue = Nothing

--

instance CaseOf HaskellChar where caseExp = haskellCharCase

haskellCharCase e rhs defaultrhs cases =
    caseE e (haskelLCharCaseBranches cases)
  where
    haskelLCharCaseBranches cases =
      case partition (isAscii . fst) cases of
	(as,us) -> vpr' (map asciiCharClass as++[uniCharClasses us])

    isAscii (ASCII _) = True
    isAscii _ = False

    asciiCharClass (ASCII c,n) = show c & "->" & rhs n

    uniCharClasses [] = "_" & "->" & defaultrhs
    uniCharClasses us =
      "c" & indented (
        vpr' $ ("|" & "isAscii" & "c" & "->" & defaultrhs):
	      map uniCharClass us ++
	      [defaultcase])

    uniCharClass (u,n) = "|" & tstFunc u & "c" & "->" & rhs n

    defaultcase = "|" & "otherwise" & "->" & defaultrhs

    tstFunc u =
      case u of
        UniWhite -> "isSpace"
	UniSymbol -> "isSymbol"
	UniDigit -> "isDigit"
	UniLarge -> "isUpper"
	UniSmall -> "isLower"

instance CaseOf Int where caseExp = simpleCase; errorValue=Just 0
instance CaseOf Char where caseExp = simpleCase

simpleCase e rhs defaultrhs cases =
    caseE e (branches cases)
  where
    branches cases = vpr' (map branch cases++[defaultbranch])

    branch (a,v) = show a & "->" & rhs v
    defaultbranch = "_" & "->" & defaultrhs

vpr' = prsep nl

caseE e bs = "case" & e & "of" & nl & indented bs