module AbsSyn (
Code, Directive(..),
Scanner(..),
RECtx(..),
RExp(..),
DFA(..), State(..), SNum, StartCode, Accept(..),
RightContext(..), showRCtx,
encodeStartCodes, extractActions,
Target(..)
) where
import CharSet ( CharSet )
import Map ( Map )
import qualified Map hiding ( Map )
import Data.IntMap (IntMap)
import Sort ( nub' )
import Util ( str, nl )
import Data.Maybe ( fromJust )
infixl 4 :|
infixl 5 :%%
type Code = String
data Directive
= WrapperDirective String
data Scanner = Scanner { Scanner -> String
scannerName :: String,
Scanner -> [RECtx]
scannerTokens :: [RECtx] }
deriving Int -> Scanner -> ShowS
[Scanner] -> ShowS
Scanner -> String
(Int -> Scanner -> ShowS)
-> (Scanner -> String) -> ([Scanner] -> ShowS) -> Show Scanner
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Scanner] -> ShowS
$cshowList :: [Scanner] -> ShowS
show :: Scanner -> String
$cshow :: Scanner -> String
showsPrec :: Int -> Scanner -> ShowS
$cshowsPrec :: Int -> Scanner -> ShowS
Show
data RECtx = RECtx { RECtx -> [(String, Int)]
reCtxStartCodes :: [(String,StartCode)],
RECtx -> Maybe CharSet
reCtxPreCtx :: Maybe CharSet,
RECtx -> RExp
reCtxRE :: RExp,
RECtx -> RightContext RExp
reCtxPostCtx :: RightContext RExp,
RECtx -> Maybe String
reCtxCode :: Maybe Code
}
data RightContext r
= NoRightContext
| RightContextRExp r
| RightContextCode Code
deriving (RightContext r -> RightContext r -> Bool
(RightContext r -> RightContext r -> Bool)
-> (RightContext r -> RightContext r -> Bool)
-> Eq (RightContext r)
forall r. Eq r => RightContext r -> RightContext r -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RightContext r -> RightContext r -> Bool
$c/= :: forall r. Eq r => RightContext r -> RightContext r -> Bool
== :: RightContext r -> RightContext r -> Bool
$c== :: forall r. Eq r => RightContext r -> RightContext r -> Bool
Eq,Eq (RightContext r)
Eq (RightContext r)
-> (RightContext r -> RightContext r -> Ordering)
-> (RightContext r -> RightContext r -> Bool)
-> (RightContext r -> RightContext r -> Bool)
-> (RightContext r -> RightContext r -> Bool)
-> (RightContext r -> RightContext r -> Bool)
-> (RightContext r -> RightContext r -> RightContext r)
-> (RightContext r -> RightContext r -> RightContext r)
-> Ord (RightContext r)
RightContext r -> RightContext r -> Bool
RightContext r -> RightContext r -> Ordering
RightContext r -> RightContext r -> RightContext r
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall r. Ord r => Eq (RightContext r)
forall r. Ord r => RightContext r -> RightContext r -> Bool
forall r. Ord r => RightContext r -> RightContext r -> Ordering
forall r.
Ord r =>
RightContext r -> RightContext r -> RightContext r
min :: RightContext r -> RightContext r -> RightContext r
$cmin :: forall r.
Ord r =>
RightContext r -> RightContext r -> RightContext r
max :: RightContext r -> RightContext r -> RightContext r
$cmax :: forall r.
Ord r =>
RightContext r -> RightContext r -> RightContext r
>= :: RightContext r -> RightContext r -> Bool
$c>= :: forall r. Ord r => RightContext r -> RightContext r -> Bool
> :: RightContext r -> RightContext r -> Bool
$c> :: forall r. Ord r => RightContext r -> RightContext r -> Bool
<= :: RightContext r -> RightContext r -> Bool
$c<= :: forall r. Ord r => RightContext r -> RightContext r -> Bool
< :: RightContext r -> RightContext r -> Bool
$c< :: forall r. Ord r => RightContext r -> RightContext r -> Bool
compare :: RightContext r -> RightContext r -> Ordering
$ccompare :: forall r. Ord r => RightContext r -> RightContext r -> Ordering
$cp1Ord :: forall r. Ord r => Eq (RightContext r)
Ord)
instance Show RECtx where
showsPrec :: Int -> RECtx -> ShowS
showsPrec Int
_ (RECtx [(String, Int)]
scs Maybe CharSet
_ RExp
r RightContext RExp
rctx Maybe String
code) =
[(String, Int)] -> ShowS
showStarts [(String, Int)]
scs ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RExp -> ShowS
forall a. Show a => a -> ShowS
shows RExp
r ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RightContext RExp -> ShowS
forall r. Show r => RightContext r -> ShowS
showRCtx RightContext RExp
rctx ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> ShowS
showMaybeCode Maybe String
code
showMaybeCode :: Maybe String -> String -> String
showMaybeCode :: Maybe String -> ShowS
showMaybeCode Maybe String
Nothing = ShowS
forall a. a -> a
id
showMaybeCode (Just String
code) = String -> ShowS
showCode String
code
showCode :: String -> String -> String
showCode :: String -> ShowS
showCode String
code = String -> ShowS
showString String
" { " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
code ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" }"
showStarts :: [(String, StartCode)] -> String -> String
showStarts :: [(String, Int)] -> ShowS
showStarts [] = ShowS
forall a. a -> a
id
showStarts [(String, Int)]
scs = [(String, Int)] -> ShowS
forall a. Show a => a -> ShowS
shows [(String, Int)]
scs
showRCtx :: Show r => RightContext r -> String -> String
showRCtx :: RightContext r -> ShowS
showRCtx RightContext r
NoRightContext = ShowS
forall a. a -> a
id
showRCtx (RightContextRExp r
r) = (Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> ShowS
forall a. Show a => a -> ShowS
shows r
r
showRCtx (RightContextCode String
code) = String -> ShowS
showString String
"\\ " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showCode String
code
data DFA s a = DFA
{ DFA s a -> [s]
dfa_start_states :: [s],
DFA s a -> Map s (State s a)
dfa_states :: Map s (State s a)
}
data State s a = State { State s a -> [Accept a]
state_acc :: [Accept a],
State s a -> IntMap s
state_out :: IntMap s
}
type SNum = Int
data Accept a
= Acc { Accept a -> Int
accPrio :: Int,
Accept a -> Maybe a
accAction :: Maybe a,
Accept a -> Maybe CharSet
accLeftCtx :: Maybe CharSet,
Accept a -> RightContext Int
accRightCtx :: RightContext SNum
}
deriving (Accept a -> Accept a -> Bool
(Accept a -> Accept a -> Bool)
-> (Accept a -> Accept a -> Bool) -> Eq (Accept a)
forall a. Eq a => Accept a -> Accept a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Accept a -> Accept a -> Bool
$c/= :: forall a. Eq a => Accept a -> Accept a -> Bool
== :: Accept a -> Accept a -> Bool
$c== :: forall a. Eq a => Accept a -> Accept a -> Bool
Eq,Eq (Accept a)
Eq (Accept a)
-> (Accept a -> Accept a -> Ordering)
-> (Accept a -> Accept a -> Bool)
-> (Accept a -> Accept a -> Bool)
-> (Accept a -> Accept a -> Bool)
-> (Accept a -> Accept a -> Bool)
-> (Accept a -> Accept a -> Accept a)
-> (Accept a -> Accept a -> Accept a)
-> Ord (Accept a)
Accept a -> Accept a -> Bool
Accept a -> Accept a -> Ordering
Accept a -> Accept a -> Accept a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Accept a)
forall a. Ord a => Accept a -> Accept a -> Bool
forall a. Ord a => Accept a -> Accept a -> Ordering
forall a. Ord a => Accept a -> Accept a -> Accept a
min :: Accept a -> Accept a -> Accept a
$cmin :: forall a. Ord a => Accept a -> Accept a -> Accept a
max :: Accept a -> Accept a -> Accept a
$cmax :: forall a. Ord a => Accept a -> Accept a -> Accept a
>= :: Accept a -> Accept a -> Bool
$c>= :: forall a. Ord a => Accept a -> Accept a -> Bool
> :: Accept a -> Accept a -> Bool
$c> :: forall a. Ord a => Accept a -> Accept a -> Bool
<= :: Accept a -> Accept a -> Bool
$c<= :: forall a. Ord a => Accept a -> Accept a -> Bool
< :: Accept a -> Accept a -> Bool
$c< :: forall a. Ord a => Accept a -> Accept a -> Bool
compare :: Accept a -> Accept a -> Ordering
$ccompare :: forall a. Ord a => Accept a -> Accept a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Accept a)
Ord)
instance Show (Accept a) where
showsPrec :: Int -> Accept a -> ShowS
showsPrec Int
_ (Acc Int
p Maybe a
_act Maybe CharSet
_lctx RightContext Int
_rctx) = Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
p
type StartCode = Int
data RExp
= Eps
| Ch CharSet
| RExp :%% RExp
| RExp :| RExp
| Star RExp
| Plus RExp
| Ques RExp
instance Show RExp where
showsPrec :: Int -> RExp -> ShowS
showsPrec Int
_ RExp
Eps = String -> ShowS
showString String
"()"
showsPrec Int
_ (Ch CharSet
_) = String -> ShowS
showString String
"[..]"
showsPrec Int
_ (RExp
l :%% RExp
r) = RExp -> ShowS
forall a. Show a => a -> ShowS
shows RExp
l ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RExp -> ShowS
forall a. Show a => a -> ShowS
shows RExp
r
showsPrec Int
_ (RExp
l :| RExp
r) = RExp -> ShowS
forall a. Show a => a -> ShowS
shows RExp
l ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'|'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RExp -> ShowS
forall a. Show a => a -> ShowS
shows RExp
r
showsPrec Int
_ (Star RExp
r) = RExp -> ShowS
forall a. Show a => a -> ShowS
shows RExp
r ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'*'Char -> ShowS
forall a. a -> [a] -> [a]
:)
showsPrec Int
_ (Plus RExp
r) = RExp -> ShowS
forall a. Show a => a -> ShowS
shows RExp
r ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'+'Char -> ShowS
forall a. a -> [a] -> [a]
:)
showsPrec Int
_ (Ques RExp
r) = RExp -> ShowS
forall a. Show a => a -> ShowS
shows RExp
r ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'?'Char -> ShowS
forall a. a -> [a] -> [a]
:)
encodeStartCodes:: Scanner -> (Scanner,[StartCode],ShowS)
encodeStartCodes :: Scanner -> (Scanner, [Int], ShowS)
encodeStartCodes Scanner
scan = (Scanner
scan', Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: ((String, Int) -> Int) -> [(String, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String, Int) -> Int
forall a b. (a, b) -> b
snd [(String, Int)]
name_code_pairs, ShowS
sc_hdr)
where
scan' :: Scanner
scan' = Scanner
scan{ scannerTokens :: [RECtx]
scannerTokens = (RECtx -> RECtx) -> [RECtx] -> [RECtx]
forall a b. (a -> b) -> [a] -> [b]
map RECtx -> RECtx
mk_re_ctx (Scanner -> [RECtx]
scannerTokens Scanner
scan) }
mk_re_ctx :: RECtx -> RECtx
mk_re_ctx (RECtx [(String, Int)]
scs Maybe CharSet
lc RExp
re RightContext RExp
rc Maybe String
code)
= [(String, Int)]
-> Maybe CharSet
-> RExp
-> RightContext RExp
-> Maybe String
-> RECtx
RECtx (((String, Int) -> (String, Int))
-> [(String, Int)] -> [(String, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (String, Int) -> (String, Int)
forall b. (String, b) -> (String, Int)
mk_sc [(String, Int)]
scs) Maybe CharSet
lc RExp
re RightContext RExp
rc Maybe String
code
mk_sc :: (String, b) -> (String, Int)
mk_sc (String
nm,b
_) = (String
nm, if String
nmString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
"0" then Int
0
else Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (String -> Map String Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
nm Map String Int
code_map))
sc_hdr :: ShowS
sc_hdr String
tl =
case [(String, Int)]
name_code_pairs of
[] -> String
tl
(String
nm,Int
_):[(String, Int)]
rst -> String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
nm String -> ShowS
forall a. [a] -> [a] -> [a]
++ ((String, Int) -> ShowS) -> String -> [(String, Int)] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String, Int) -> ShowS
forall b. (String, b) -> ShowS
f String
t [(String, Int)]
rst
where
f :: (String, b) -> ShowS
f (String
nm', b
_) String
t' = String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
nm' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
t'
t :: String
t = String
" :: Int\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ((String, Int) -> ShowS) -> String -> [(String, Int)] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String, Int) -> ShowS
forall a. Show a => (String, a) -> ShowS
fmt_sc String
tl [(String, Int)]
name_code_pairs
where
fmt_sc :: (String, a) -> ShowS
fmt_sc (String
nm,a
sc) String
t = String
nm String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
sc String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
t
code_map :: Map String Int
code_map = [(String, Int)] -> Map String Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, Int)]
name_code_pairs
name_code_pairs :: [(String, Int)]
name_code_pairs = [String] -> [Int] -> [(String, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((String -> String -> Bool) -> [String] -> [String]
forall a. (a -> a -> Bool) -> [a] -> [a]
nub' String -> String -> Bool
forall a. Ord a => a -> a -> Bool
(<=) [String]
nms) [Int
1..]
nms :: [String]
nms = [String
nm | RECtx{reCtxStartCodes :: RECtx -> [(String, Int)]
reCtxStartCodes = [(String, Int)]
scs} <- Scanner -> [RECtx]
scannerTokens Scanner
scan,
(String
nm,Int
_) <- [(String, Int)]
scs, String
nm String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"0"]
extractActions :: Scanner -> (Scanner,ShowS)
Scanner
scanner = (Scanner
scanner{scannerTokens :: [RECtx]
scannerTokens = [RECtx]
new_tokens}, ShowS
decl_str)
where
([RECtx]
new_tokens, [Maybe ShowS]
decls) = [(RECtx, Maybe ShowS)] -> ([RECtx], [Maybe ShowS])
forall a b. [(a, b)] -> ([a], [b])
unzip ((RECtx -> String -> (RECtx, Maybe ShowS))
-> [RECtx] -> [String] -> [(RECtx, Maybe ShowS)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith RECtx -> String -> (RECtx, Maybe ShowS)
f (Scanner -> [RECtx]
scannerTokens Scanner
scanner) [String]
act_names)
f :: RECtx -> String -> (RECtx, Maybe ShowS)
f r :: RECtx
r@RECtx{ reCtxCode :: RECtx -> Maybe String
reCtxCode = Just String
code } String
name
= (RECtx
r{reCtxCode :: Maybe String
reCtxCode = String -> Maybe String
forall a. a -> Maybe a
Just String
name}, ShowS -> Maybe ShowS
forall a. a -> Maybe a
Just (String -> String -> ShowS
mkDecl String
name String
code))
f r :: RECtx
r@RECtx{ reCtxCode :: RECtx -> Maybe String
reCtxCode = Maybe String
Nothing } String
_
= (RECtx
r{reCtxCode :: Maybe String
reCtxCode = Maybe String
forall a. Maybe a
Nothing}, Maybe ShowS
forall a. Maybe a
Nothing)
mkDecl :: String -> String -> ShowS
mkDecl String
fun String
code = String -> ShowS
str String
fun ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
str String
" = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
str String
code ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
nl
act_names :: [String]
act_names = (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
n -> String
"alex_action_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
n::Int)) [Int
0..]
decl_str :: ShowS
decl_str = (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id [ ShowS
decl | Just ShowS
decl <- [Maybe ShowS]
decls ]
data Target = GhcTarget | HaskellTarget