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