module CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..), CHSParm(..),
CHSArg(..), CHSAccess(..), CHSAPath(..), CHSPtrType(..),
skipToLangPragma, hasCPP,
loadCHS, dumpCHS, hssuffix, chssuffix, loadAllCHI, loadCHI, dumpCHI,
chisuffix, showCHSParm)
where
import Data.Char (isSpace, toUpper, toLower)
import Data.List (intersperse)
import Control.Monad (when, unless)
import Position (Position(..), Pos(posOf), nopos, isBuiltinPos)
import Errors (interr)
import Idents (Ident, identToLexeme, onlyPosIdent)
import C2HSState (CST, nop, doesFileExistCIO, readFileCIO, writeFileCIO, getId,
getSwitch, chiPathSB, catchExc, throwExc, raiseError,
fatal, errorsPresent, showErrors, Traces(..), putTraceStr)
import CHSLexer (CHSToken(..), lexCHS)
data CHSModule = CHSModule [CHSFrag]
data CHSFrag = CHSVerb String
Position
| CHSHook CHSHook
| CHSCPP String
Position
| CHSLine Position
| CHSC String
Position
| CHSCond [(Ident,
[CHSFrag])]
(Maybe [CHSFrag])
| CHSLang [String]
Position
instance Pos CHSFrag where
posOf :: CHSFrag -> Position
posOf (CHSVerb String
_ Position
pos ) = Position
pos
posOf (CHSHook CHSHook
hook ) = CHSHook -> Position
forall a. Pos a => a -> Position
posOf CHSHook
hook
posOf (CHSCPP String
_ Position
pos ) = Position
pos
posOf (CHSLine Position
pos ) = Position
pos
posOf (CHSC String
_ Position
pos ) = Position
pos
posOf (CHSCond [(Ident, [CHSFrag])]
alts Maybe [CHSFrag]
_) = case [(Ident, [CHSFrag])]
alts of
(Ident
_, CHSFrag
frag:[CHSFrag]
_):[(Ident, [CHSFrag])]
_ -> CHSFrag -> Position
forall a. Pos a => a -> Position
posOf CHSFrag
frag
[(Ident, [CHSFrag])]
_ -> Position
nopos
posOf (CHSLang [String]
_ Position
pos) = Position
pos
data CHSHook = CHSImport Bool
Ident
String
Position
| CHSContext (Maybe String)
(Maybe String)
(Maybe String)
Position
| CHSType Ident
Position
| CHSSizeof Ident
Position
| CHSEnum Ident
(Maybe Ident)
CHSTrans
(Maybe String)
[Ident]
Position
| CHSCall Bool
Bool
Bool
Ident
(Maybe Ident)
Position
| CHSFun Bool
Bool
Bool
Ident
(Maybe Ident)
(Maybe String)
[CHSParm]
CHSParm
Position
| CHSField CHSAccess
CHSAPath
Position
| CHSPointer Bool
Ident
(Maybe Ident)
CHSPtrType
Bool
(Maybe Ident)
Position
| CHSClass (Maybe Ident)
Ident
Ident
Position
instance Pos CHSHook where
posOf :: CHSHook -> Position
posOf (CHSImport Bool
_ Ident
_ String
_ Position
pos) = Position
pos
posOf (CHSContext Maybe String
_ Maybe String
_ Maybe String
_ Position
pos) = Position
pos
posOf (CHSType Ident
_ Position
pos) = Position
pos
posOf (CHSSizeof Ident
_ Position
pos) = Position
pos
posOf (CHSEnum Ident
_ Maybe Ident
_ CHSTrans
_ Maybe String
_ [Ident]
_ Position
pos) = Position
pos
posOf (CHSCall Bool
_ Bool
_ Bool
_ Ident
_ Maybe Ident
_ Position
pos) = Position
pos
posOf (CHSFun Bool
_ Bool
_ Bool
_ Ident
_ Maybe Ident
_ Maybe String
_ [CHSParm]
_ CHSParm
_ Position
pos) = Position
pos
posOf (CHSField CHSAccess
_ CHSAPath
_ Position
pos) = Position
pos
posOf (CHSPointer Bool
_ Ident
_ Maybe Ident
_ CHSPtrType
_ Bool
_ Maybe Ident
_ Position
pos) = Position
pos
posOf (CHSClass Maybe Ident
_ Ident
_ Ident
_ Position
pos) = Position
pos
instance Eq CHSHook where
(CHSImport Bool
qual1 Ident
ide1 String
_ Position
_) == :: CHSHook -> CHSHook -> Bool
== (CHSImport Bool
qual2 Ident
ide2 String
_ Position
_) =
Bool
qual1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
qual2 Bool -> Bool -> Bool
&& Ident
ide1 Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
ide2
(CHSContext Maybe String
olib1 Maybe String
opref1 Maybe String
olock1 Position
_ ) ==
(CHSContext Maybe String
olib2 Maybe String
opref2 Maybe String
olock2 Position
_ ) =
Maybe String
olib1 Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
olib1 Bool -> Bool -> Bool
&& Maybe String
opref1 Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
opref2 Bool -> Bool -> Bool
&& Maybe String
olock1 Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
olock2
(CHSType Ident
ide1 Position
_) == (CHSType Ident
ide2 Position
_) =
Ident
ide1 Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
ide2
(CHSSizeof Ident
ide1 Position
_) == (CHSSizeof Ident
ide2 Position
_) =
Ident
ide1 Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
ide2
(CHSEnum Ident
ide1 Maybe Ident
oalias1 CHSTrans
_ Maybe String
_ [Ident]
_ Position
_) == (CHSEnum Ident
ide2 Maybe Ident
oalias2 CHSTrans
_ Maybe String
_ [Ident]
_ Position
_) =
Maybe Ident
oalias1 Maybe Ident -> Maybe Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Ident
oalias2 Bool -> Bool -> Bool
&& Ident
ide1 Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
ide2
(CHSCall Bool
_ Bool
_ Bool
_ Ident
ide1 Maybe Ident
oalias1 Position
_) == (CHSCall Bool
_ Bool
_ Bool
_ Ident
ide2 Maybe Ident
oalias2 Position
_) =
Maybe Ident
oalias1 Maybe Ident -> Maybe Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Ident
oalias2 Bool -> Bool -> Bool
&& Ident
ide1 Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
ide2
(CHSFun Bool
_ Bool
_ Bool
_ Ident
ide1 Maybe Ident
oalias1 Maybe String
_ [CHSParm]
_ CHSParm
_ Position
_)
== (CHSFun Bool
_ Bool
_ Bool
_ Ident
ide2 Maybe Ident
oalias2 Maybe String
_ [CHSParm]
_ CHSParm
_ Position
_) =
Maybe Ident
oalias1 Maybe Ident -> Maybe Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Ident
oalias2 Bool -> Bool -> Bool
&& Ident
ide1 Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
ide2
(CHSField CHSAccess
acc1 CHSAPath
path1 Position
_) == (CHSField CHSAccess
acc2 CHSAPath
path2 Position
_) =
CHSAccess
acc1 CHSAccess -> CHSAccess -> Bool
forall a. Eq a => a -> a -> Bool
== CHSAccess
acc2 Bool -> Bool -> Bool
&& CHSAPath
path1 CHSAPath -> CHSAPath -> Bool
forall a. Eq a => a -> a -> Bool
== CHSAPath
path2
(CHSPointer Bool
_ Ident
ide1 Maybe Ident
oalias1 CHSPtrType
_ Bool
_ Maybe Ident
_ Position
_)
== (CHSPointer Bool
_ Ident
ide2 Maybe Ident
oalias2 CHSPtrType
_ Bool
_ Maybe Ident
_ Position
_) =
Ident
ide1 Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
ide2 Bool -> Bool -> Bool
&& Maybe Ident
oalias1 Maybe Ident -> Maybe Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Ident
oalias2
(CHSClass Maybe Ident
_ Ident
ide1 Ident
_ Position
_) == (CHSClass Maybe Ident
_ Ident
ide2 Ident
_ Position
_) =
Ident
ide1 Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
ide2
CHSHook
_ == CHSHook
_ = Bool
False
data CHSTrans = CHSTrans Bool
[(Ident, Ident)]
data CHSParm = CHSParm (Maybe (Ident, CHSArg))
String
Bool
(Maybe (Ident, CHSArg))
Position
data CHSArg = CHSValArg
| CHSIOArg
| CHSVoidArg
deriving (CHSArg -> CHSArg -> Bool
(CHSArg -> CHSArg -> Bool)
-> (CHSArg -> CHSArg -> Bool) -> Eq CHSArg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CHSArg -> CHSArg -> Bool
$c/= :: CHSArg -> CHSArg -> Bool
== :: CHSArg -> CHSArg -> Bool
$c== :: CHSArg -> CHSArg -> Bool
Eq)
data CHSAccess = CHSSet
| CHSGet
deriving (CHSAccess -> CHSAccess -> Bool
(CHSAccess -> CHSAccess -> Bool)
-> (CHSAccess -> CHSAccess -> Bool) -> Eq CHSAccess
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CHSAccess -> CHSAccess -> Bool
$c/= :: CHSAccess -> CHSAccess -> Bool
== :: CHSAccess -> CHSAccess -> Bool
$c== :: CHSAccess -> CHSAccess -> Bool
Eq)
data CHSAPath = CHSRoot Ident
| CHSDeref CHSAPath Position
| CHSRef CHSAPath Ident
deriving (CHSAPath -> CHSAPath -> Bool
(CHSAPath -> CHSAPath -> Bool)
-> (CHSAPath -> CHSAPath -> Bool) -> Eq CHSAPath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CHSAPath -> CHSAPath -> Bool
$c/= :: CHSAPath -> CHSAPath -> Bool
== :: CHSAPath -> CHSAPath -> Bool
$c== :: CHSAPath -> CHSAPath -> Bool
Eq)
data CHSPtrType = CHSPtr
| CHSForeignPtr
| CHSStablePtr
deriving (CHSPtrType -> CHSPtrType -> Bool
(CHSPtrType -> CHSPtrType -> Bool)
-> (CHSPtrType -> CHSPtrType -> Bool) -> Eq CHSPtrType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CHSPtrType -> CHSPtrType -> Bool
$c/= :: CHSPtrType -> CHSPtrType -> Bool
== :: CHSPtrType -> CHSPtrType -> Bool
$c== :: CHSPtrType -> CHSPtrType -> Bool
Eq)
instance Show CHSPtrType where
show :: CHSPtrType -> String
show CHSPtrType
CHSPtr = String
"Ptr"
show CHSPtrType
CHSForeignPtr = String
"ForeignPtr"
show CHSPtrType
CHSStablePtr = String
"StablePtr"
instance Read CHSPtrType where
readsPrec :: Int -> ReadS CHSPtrType
readsPrec Int
_ ( Char
'P':Char
't':Char
'r':String
rest) =
[(CHSPtrType
CHSPtr, String
rest)]
readsPrec Int
_ (Char
'F':Char
'o':Char
'r':Char
'e':Char
'i':Char
'g':Char
'n':Char
'P':Char
't':Char
'r':String
rest) =
[(CHSPtrType
CHSForeignPtr, String
rest)]
readsPrec Int
_ (Char
'S':Char
't':Char
'a':Char
'b':Char
'l':Char
'e' :Char
'P':Char
't':Char
'r':String
rest) =
[(CHSPtrType
CHSStablePtr, String
rest)]
readsPrec Int
p (Char
c:String
cs)
| Char -> Bool
isSpace Char
c = Int -> ReadS CHSPtrType
forall a. Read a => Int -> ReadS a
readsPrec Int
p String
cs
readsPrec Int
_ String
_ = []
skipToLangPragma :: CHSModule -> Maybe CHSModule
skipToLangPragma :: CHSModule -> Maybe CHSModule
skipToLangPragma (CHSModule [CHSFrag]
frags) = [CHSFrag] -> Maybe CHSModule
hLP [CHSFrag]
frags
where
hLP :: [CHSFrag] -> Maybe CHSModule
hLP all :: [CHSFrag]
all@(CHSLang [String]
exts Position
_:[CHSFrag]
_) = CHSModule -> Maybe CHSModule
forall a. a -> Maybe a
Just ([CHSFrag] -> CHSModule
CHSModule [CHSFrag]
all)
hLP (CHSFrag
x:[CHSFrag]
xs) = [CHSFrag] -> Maybe CHSModule
hLP [CHSFrag]
xs
hLP [] = Maybe CHSModule
forall a. Maybe a
Nothing
hasCPP :: CHSModule -> Bool
hasCPP :: CHSModule -> Bool
hasCPP (CHSModule (CHSLang [String]
exts Position
_:[CHSFrag]
_)) = String
"CPP" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
exts
hasCPP CHSModule
_ = Bool
False
hssuffix, chssuffix :: String
hssuffix :: String
hssuffix = String
".hs"
chssuffix :: String
chssuffix = String
".chs"
loadCHS :: FilePath -> CST s (CHSModule, String)
loadCHS :: String -> CST s (CHSModule, String)
loadCHS String
fname = do
String -> CST s ()
forall s. String -> CST s ()
traceInfoRead String
fname
String
contents <- String -> PreCST SwitchBoard s String
forall e s. String -> PreCST e s String
readFileCIO String
fname
CST s ()
forall s. CST s ()
traceInfoParse
CHSModule
mod <- Position -> String -> CST s CHSModule
forall s. Position -> String -> CST s CHSModule
parseCHSModule (String -> Int -> Int -> Position
Position String
fname Int
1 Int
1) String
contents
Bool
errs <- PreCST SwitchBoard s Bool
forall e s. PreCST e s Bool
errorsPresent
if Bool
errs
then do
CST s ()
forall s. CST s ()
traceInfoErr
String
errmsgs <- PreCST SwitchBoard s String
forall e s. PreCST e s String
showErrors
String -> CST s (CHSModule, String)
forall e s a. String -> PreCST e s a
fatal (String
"CHS module contains \
\errors:\n\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
errmsgs)
else do
CST s ()
forall s. CST s ()
traceInfoOK
String
warnmsgs <- PreCST SwitchBoard s String
forall e s. PreCST e s String
showErrors
(CHSModule, String) -> CST s (CHSModule, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (CHSModule
mod, String
warnmsgs)
where
traceInfoRead :: String -> CST s ()
traceInfoRead String
fname = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
(String
"Attempting to read file `"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'...\n")
traceInfoParse :: CST s ()
traceInfoParse = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
(String
"...parsing `"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'...\n")
traceInfoErr :: CST s ()
traceInfoErr = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
(String
"...error(s) detected in `"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'.\n")
traceInfoOK :: CST s ()
traceInfoOK = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
(String
"...successfully loaded `"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'.\n")
dumpCHS :: String -> CHSModule -> Bool -> CST s ()
dumpCHS :: String -> CHSModule -> Bool -> CST s ()
dumpCHS String
fname CHSModule
mod Bool
pureHaskell =
do
let (String
suffix, String
kind) = if Bool
pureHaskell
then (String
hssuffix , String
"(Haskell)")
else (String
chssuffix, String
"(C->HS binding)")
(String
version, String
_, String
_) <- PreCST SwitchBoard s (String, String, String)
forall e s. PreCST e s (String, String, String)
getId
String -> String -> CST s ()
forall e s. String -> String -> PreCST e s ()
writeFileCIO (String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
suffix) (String -> ShowS
contents String
version String
kind)
where
contents :: String -> ShowS
contents String
version String
kind | CHSModule -> Bool
hasCPP CHSModule
mod = CHSModule -> Bool -> String
showCHSModule CHSModule
mod Bool
pureHaskell
| Bool
otherwise =
String
"-- GENERATED by " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
version String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
kind String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n\
\-- Edit the ORIGNAL .chs file instead!\n\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ CHSModule -> Bool -> String
showCHSModule CHSModule
mod Bool
pureHaskell
data LineState = Emit
| Wait
| NoLine
deriving (LineState -> LineState -> Bool
(LineState -> LineState -> Bool)
-> (LineState -> LineState -> Bool) -> Eq LineState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LineState -> LineState -> Bool
$c/= :: LineState -> LineState -> Bool
== :: LineState -> LineState -> Bool
$c== :: LineState -> LineState -> Bool
Eq)
showCHSModule :: CHSModule -> Bool -> String
showCHSModule :: CHSModule -> Bool -> String
showCHSModule (CHSModule [CHSFrag]
frags) Bool
pureHaskell =
Bool -> LineState -> [CHSFrag] -> ShowS
showFrags Bool
pureHaskell LineState
Emit [CHSFrag]
frags []
where
showFrags :: Bool -> LineState -> [CHSFrag] -> ShowS
showFrags :: Bool -> LineState -> [CHSFrag] -> ShowS
showFrags Bool
_ LineState
_ [] = ShowS
forall a. a -> a
id
showFrags Bool
pureHs LineState
state (CHSVerb String
s Position
pos : [CHSFrag]
frags) =
let
(Position String
fname Int
line Int
_) = Position
pos
generated :: Bool
generated = Position -> Bool
isBuiltinPos Position
pos
emitNow :: Bool
emitNow = LineState
state LineState -> LineState -> Bool
forall a. Eq a => a -> a -> Bool
== LineState
Emit Bool -> Bool -> Bool
||
(LineState
state LineState -> LineState -> Bool
forall a. Eq a => a -> a -> Bool
== LineState
Wait Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) Bool -> Bool -> Bool
&& Bool
nlStart)
nlStart :: Bool
nlStart = String -> Char
forall a. [a] -> a
head String
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n'
nextState :: LineState
nextState = if Bool
generated then LineState
Wait else LineState
NoLine
in
(if Bool
emitNow then
String -> ShowS
showString (String
"\n{-# LINE " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
line Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` Int
0) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++
ShowS
forall a. Show a => a -> String
show String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" #-}" String -> ShowS
forall a. [a] -> [a] -> [a]
++
(if Bool
nlStart then String
"" else String
"\n"))
else ShowS
forall a. a -> a
id)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
s
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> LineState -> [CHSFrag] -> ShowS
showFrags Bool
pureHs LineState
nextState [CHSFrag]
frags
showFrags Bool
False LineState
_ (CHSHook CHSHook
hook : [CHSFrag]
frags) =
String -> ShowS
showString String
"{#"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CHSHook -> ShowS
showCHSHook CHSHook
hook
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"#}"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> LineState -> [CHSFrag] -> ShowS
showFrags Bool
False LineState
Wait [CHSFrag]
frags
showFrags Bool
False LineState
_ (CHSCPP String
s Position
_ : [CHSFrag]
frags) =
Char -> ShowS
showChar Char
'#'
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
s
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> LineState -> [CHSFrag] -> ShowS
showFrags Bool
False LineState
Emit [CHSFrag]
frags
showFrags Bool
pureHs LineState
_ (CHSLine Position
s : [CHSFrag]
frags) =
Bool -> LineState -> [CHSFrag] -> ShowS
showFrags Bool
pureHs LineState
Emit [CHSFrag]
frags
showFrags Bool
False LineState
_ (CHSC String
s Position
_ : [CHSFrag]
frags) =
String -> ShowS
showString String
"\n#c"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
s
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"\n#endc"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> LineState -> [CHSFrag] -> ShowS
showFrags Bool
False LineState
Emit [CHSFrag]
frags
showFrags Bool
False LineState
_ (CHSCond [(Ident, [CHSFrag])]
_ Maybe [CHSFrag]
_ : [CHSFrag]
frags) =
String -> ShowS
forall a. String -> a
interr String
"showCHSFrag: Cannot print `CHSCond'!"
showFrags Bool
pureHs LineState
_ (CHSLang [String]
exts Position
_ : [CHSFrag]
frags) =
let extsNoCPP :: [String]
extsNoCPP = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(/=) String
"CPP") [String]
exts in
if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
extsNoCPP then Bool -> LineState -> [CHSFrag] -> ShowS
showFrags Bool
pureHs LineState
Emit [CHSFrag]
frags else
String -> ShowS
showString String
"{-# LANGUAGE "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"," [String]
extsNoCPP))
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" #-}\n"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> LineState -> [CHSFrag] -> ShowS
showFrags Bool
pureHs LineState
Emit [CHSFrag]
frags
showFrags Bool
True LineState
_ [CHSFrag]
_ =
String -> ShowS
forall a. String -> a
interr String
"showCHSFrag: Illegal hook, cpp directive, or inline C code!"
showCHSHook :: CHSHook -> ShowS
showCHSHook :: CHSHook -> ShowS
showCHSHook (CHSImport Bool
isQual Ident
ide String
_ Position
_) =
String -> ShowS
showString String
"import "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isQual then String -> ShowS
showString String
"qualified " else ShowS
forall a. a -> a
id)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide
showCHSHook (CHSContext Maybe String
olib Maybe String
oprefix Maybe String
olock Position
_) =
String -> ShowS
showString String
"context "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case Maybe String
olib of
Maybe String
Nothing -> String -> ShowS
showString String
""
Just String
lib -> String -> ShowS
showString String
"lib = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
lib ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" ")
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> Bool -> ShowS
showPrefix Maybe String
oprefix Bool
False
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case Maybe String
olock of
Maybe String
Nothing -> String -> ShowS
showString String
""
Just String
lock -> String -> ShowS
showString String
"lock = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
lock ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" ")
showCHSHook (CHSType Ident
ide Position
_) =
String -> ShowS
showString String
"type "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide
showCHSHook (CHSSizeof Ident
ide Position
_) =
String -> ShowS
showString String
"sizeof "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide
showCHSHook (CHSEnum Ident
ide Maybe Ident
oalias CHSTrans
trans Maybe String
oprefix [Ident]
derive Position
_) =
String -> ShowS
showString String
"enum "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Maybe Ident -> ShowS
showIdAlias Ident
ide Maybe Ident
oalias
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CHSTrans -> ShowS
showCHSTrans CHSTrans
trans
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> Bool -> ShowS
showPrefix Maybe String
oprefix Bool
True
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. if [Ident] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ident]
derive then ShowS
forall a. a -> a
id else String -> ShowS
showString (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$
String
"deriving ("
String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
", " ((Ident -> String) -> [Ident] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> String
identToLexeme [Ident]
derive))
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") "
showCHSHook (CHSCall Bool
isPure Bool
isUns Bool
isNol Ident
ide Maybe Ident
oalias Position
_) =
String -> ShowS
showString String
"call "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isPure then String -> ShowS
showString String
"pure " else ShowS
forall a. a -> a
id)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isUns then String -> ShowS
showString String
"unsafe " else ShowS
forall a. a -> a
id)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isNol then String -> ShowS
showString String
"nolock " else ShowS
forall a. a -> a
id)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Maybe Ident -> ShowS
showIdAlias Ident
ide Maybe Ident
oalias
showCHSHook (CHSFun Bool
isPure Bool
isUns Bool
isNol Ident
ide Maybe Ident
oalias Maybe String
octxt [CHSParm]
parms CHSParm
parm Position
_) =
String -> ShowS
showString String
"fun "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isPure then String -> ShowS
showString String
"pure " else ShowS
forall a. a -> a
id)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isUns then String -> ShowS
showString String
"unsafe " else ShowS
forall a. a -> a
id)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isNol then String -> ShowS
showString String
"nolock " else ShowS
forall a. a -> a
id)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Maybe Ident -> ShowS
showIdAlias Ident
ide Maybe Ident
oalias
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case Maybe String
octxt of
Maybe String
Nothing -> Char -> ShowS
showChar Char
' '
Just String
ctxtStr -> String -> ShowS
showString String
ctxtStr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" => ")
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"{"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
intersperse (String -> ShowS
showString String
", ") ((CHSParm -> ShowS) -> [CHSParm] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map CHSParm -> ShowS
showCHSParm [CHSParm]
parms))
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"} -> "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CHSParm -> ShowS
showCHSParm CHSParm
parm
showCHSHook (CHSField CHSAccess
acc CHSAPath
path Position
_) =
(case CHSAccess
acc of
CHSAccess
CHSGet -> String -> ShowS
showString String
"get "
CHSAccess
CHSSet -> String -> ShowS
showString String
"set ")
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CHSAPath -> ShowS
showCHSAPath CHSAPath
path
showCHSHook (CHSPointer Bool
star Ident
ide Maybe Ident
oalias CHSPtrType
ptrType Bool
isNewtype Maybe Ident
oRefType Position
_) =
String -> ShowS
showString String
"pointer "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
star then String -> ShowS
showString String
"*" else String -> ShowS
showString String
"")
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Maybe Ident -> ShowS
showIdAlias Ident
ide Maybe Ident
oalias
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case CHSPtrType
ptrType of
CHSPtrType
CHSForeignPtr -> String -> ShowS
showString String
" foreign"
CHSPtrType
CHSStablePtr -> String -> ShowS
showString String
" stable"
CHSPtrType
_ -> String -> ShowS
showString String
"")
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case (Bool
isNewtype, Maybe Ident
oRefType) of
(Bool
True , Maybe Ident
_ ) -> String -> ShowS
showString String
" newtype"
(Bool
False, Just Ident
ide) -> String -> ShowS
showString String
" -> " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide
(Bool
False, Maybe Ident
Nothing ) -> String -> ShowS
showString String
"")
showCHSHook (CHSClass Maybe Ident
oclassIde Ident
classIde Ident
typeIde Position
_) =
String -> ShowS
showString String
"class "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case Maybe Ident
oclassIde of
Maybe Ident
Nothing -> String -> ShowS
showString String
""
Just Ident
classIde -> Ident -> ShowS
showCHSIdent Ident
classIde ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" => ")
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
classIde
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
typeIde
showPrefix :: Maybe String -> Bool -> ShowS
showPrefix :: Maybe String -> Bool -> ShowS
showPrefix Maybe String
Nothing Bool
_ = String -> ShowS
showString String
""
showPrefix (Just String
prefix) Bool
withWith = ShowS
maybeWith
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"prefix = "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
prefix
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
where
maybeWith :: ShowS
maybeWith = if Bool
withWith then String -> ShowS
showString String
"with " else ShowS
forall a. a -> a
id
showIdAlias :: Ident -> Maybe Ident -> ShowS
showIdAlias :: Ident -> Maybe Ident -> ShowS
showIdAlias Ident
ide Maybe Ident
oalias =
Ident -> ShowS
showCHSIdent Ident
ide
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case Maybe Ident
oalias of
Maybe Ident
Nothing -> ShowS
forall a. a -> a
id
Just Ident
ide -> String -> ShowS
showString String
" as " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide)
showCHSParm :: CHSParm -> ShowS
showCHSParm :: CHSParm -> ShowS
showCHSParm (CHSParm Maybe (Ident, CHSArg)
oimMarsh String
hsTyStr Bool
twoCVals Maybe (Ident, CHSArg)
oomMarsh Position
_) =
Maybe (Ident, CHSArg) -> ShowS
showOMarsh Maybe (Ident, CHSArg)
oimMarsh
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showHsVerb String
hsTyStr
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
twoCVals then Char -> ShowS
showChar Char
'&' else ShowS
forall a. a -> a
id)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Ident, CHSArg) -> ShowS
showOMarsh Maybe (Ident, CHSArg)
oomMarsh
where
showOMarsh :: Maybe (Ident, CHSArg) -> ShowS
showOMarsh Maybe (Ident, CHSArg)
Nothing = ShowS
forall a. a -> a
id
showOMarsh (Just (Ident
ide, CHSArg
argKind)) = Ident -> ShowS
showCHSIdent Ident
ide
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case CHSArg
argKind of
CHSArg
CHSValArg -> ShowS
forall a. a -> a
id
CHSArg
CHSIOArg -> String -> ShowS
showString String
"*"
CHSArg
CHSVoidArg -> String -> ShowS
showString String
"-")
showHsVerb :: String -> ShowS
showHsVerb String
str = Char -> ShowS
showChar Char
'`' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
str ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'\''
showCHSTrans :: CHSTrans -> ShowS
showCHSTrans :: CHSTrans -> ShowS
showCHSTrans (CHSTrans Bool
_2Case [(Ident, Ident)]
assocs) =
String -> ShowS
showString String
"{"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
_2Case then String -> ShowS
showString (String
"underscoreToCase" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
maybeComma) else ShowS
forall a. a -> a
id)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
intersperse (String -> ShowS
showString String
", ") (((Ident, Ident) -> ShowS) -> [(Ident, Ident)] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map (Ident, Ident) -> ShowS
showAssoc [(Ident, Ident)]
assocs))
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"}"
where
maybeComma :: String
maybeComma = if [(Ident, Ident)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Ident, Ident)]
assocs then String
"" else String
", "
showAssoc :: (Ident, Ident) -> ShowS
showAssoc (Ident
ide1, Ident
ide2) =
Ident -> ShowS
showCHSIdent Ident
ide1
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" as "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide2
showCHSAPath :: CHSAPath -> ShowS
showCHSAPath :: CHSAPath -> ShowS
showCHSAPath (CHSRoot Ident
ide) =
Ident -> ShowS
showCHSIdent Ident
ide
showCHSAPath (CHSDeref CHSAPath
path Position
_) =
String -> ShowS
showString String
"* "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CHSAPath -> ShowS
showCHSAPath CHSAPath
path
showCHSAPath (CHSRef (CHSDeref CHSAPath
path Position
_) Ident
ide) =
CHSAPath -> ShowS
showCHSAPath CHSAPath
path
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"->"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide
showCHSAPath (CHSRef CHSAPath
path Ident
ide) =
CHSAPath -> ShowS
showCHSAPath CHSAPath
path
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"."
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide
showCHSIdent :: Ident -> ShowS
showCHSIdent :: Ident -> ShowS
showCHSIdent = String -> ShowS
showString (String -> ShowS) -> (Ident -> String) -> Ident -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> String
identToLexeme
chisuffix :: String
chisuffix :: String
chisuffix = String
".chi"
versionPrefix :: String
versionPrefix :: String
versionPrefix = String
"C->Haskell Interface Version "
loadAllCHI :: CHSModule -> CST s CHSModule
loadAllCHI :: CHSModule -> CST s CHSModule
loadAllCHI (CHSModule [CHSFrag]
frags) = do
let checkFrag :: CHSFrag -> PreCST SwitchBoard s CHSFrag
checkFrag (CHSHook (CHSImport Bool
qual Ident
name String
fName Position
pos)) = do
String
chi <- String -> CST s String
forall s. String -> CST s String
loadCHI String
fName
CHSFrag -> PreCST SwitchBoard s CHSFrag
forall (m :: * -> *) a. Monad m => a -> m a
return (CHSHook -> CHSFrag
CHSHook (Bool -> Ident -> String -> Position -> CHSHook
CHSImport Bool
qual Ident
name String
chi Position
pos))
checkFrag CHSFrag
h = CHSFrag -> PreCST SwitchBoard s CHSFrag
forall (m :: * -> *) a. Monad m => a -> m a
return CHSFrag
h
[CHSFrag]
frags' <- (CHSFrag -> PreCST SwitchBoard s CHSFrag)
-> [CHSFrag] -> PreCST SwitchBoard s [CHSFrag]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CHSFrag -> PreCST SwitchBoard s CHSFrag
forall s. CHSFrag -> PreCST SwitchBoard s CHSFrag
checkFrag [CHSFrag]
frags
CHSModule -> CST s CHSModule
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CHSModule
CHSModule [CHSFrag]
frags')
loadCHI :: FilePath -> CST s String
loadCHI :: String -> CST s String
loadCHI String
fname = do
[String]
paths <- (SwitchBoard -> [String]) -> CST s [String]
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> [String]
chiPathSB
let fullnames :: [String]
fullnames = [String
path String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'/'Char -> ShowS
forall a. a -> [a] -> [a]
:String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
chisuffix |
String
path <- [String]
paths]
String
fullname <- [String] -> CST s String -> CST s String
forall e s. [String] -> PreCST e s String -> PreCST e s String
findFirst [String]
fullnames
(String -> CST s String
forall e s a. String -> PreCST e s a
fatal (String -> CST s String) -> String -> CST s String
forall a b. (a -> b) -> a -> b
$ String
fnameString -> ShowS
forall a. [a] -> [a] -> [a]
++String
chisuffixString -> ShowS
forall a. [a] -> [a] -> [a]
++String
" not found in:\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++
[String] -> String
unlines [String]
paths)
String -> CST s ()
forall s. String -> CST s ()
traceInfoRead String
fullname
String
contents <- String -> CST s String
forall e s. String -> PreCST e s String
readFileCIO String
fullname
CST s ()
forall s. CST s ()
traceInfoVersion
let ls :: [String]
ls = String -> [String]
lines String
contents
Bool -> CST s () -> CST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
ls) (CST s () -> CST s ()) -> CST s () -> CST s ()
forall a b. (a -> b) -> a -> b
$
String -> CST s ()
forall s a. String -> CST s a
errorCHICorrupt String
fname
let String
versline:[String]
chi = [String]
ls
prefixLen :: Int
prefixLen = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
versionPrefix
Bool -> CST s () -> CST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
versline Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
prefixLen
Bool -> Bool -> Bool
|| Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
prefixLen String
versline String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
versionPrefix) (CST s () -> CST s ()) -> CST s () -> CST s ()
forall a b. (a -> b) -> a -> b
$
String -> CST s ()
forall s a. String -> CST s a
errorCHICorrupt String
fname
let versline' :: String
versline' = Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
prefixLen String
versline
(String
major, String
minor) <- case String -> Maybe (String, String)
majorMinor String
versline' of
Maybe (String, String)
Nothing -> String -> PreCST SwitchBoard s (String, String)
forall s a. String -> CST s a
errorCHICorrupt String
fname
Just (String, String)
majMin -> (String, String) -> PreCST SwitchBoard s (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String, String)
majMin
(String
version, String
_, String
_) <- PreCST SwitchBoard s (String, String, String)
forall e s. PreCST e s (String, String, String)
getId
let Just (String
myMajor, String
myMinor) = String -> Maybe (String, String)
majorMinor String
version
Bool -> CST s () -> CST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
major String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
myMajor Bool -> Bool -> Bool
|| String
minor String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
myMinor) (CST s () -> CST s ()) -> CST s () -> CST s ()
forall a b. (a -> b) -> a -> b
$
String -> String -> String -> CST s ()
forall s a. String -> String -> String -> CST s a
errorCHIVersion String
fname
(String
major String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
minor) (String
myMajor String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
myMinor)
CST s ()
forall s. CST s ()
traceInfoOK
String -> CST s String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> CST s String) -> String -> CST s String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
chi
where
traceInfoRead :: String -> CST s ()
traceInfoRead String
fname = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
(String
"Attempting to read file `"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'...\n")
traceInfoVersion :: CST s ()
traceInfoVersion = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
(String
"...checking version `"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'...\n")
traceInfoOK :: CST s ()
traceInfoOK = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
(String
"...successfully loaded `"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'.\n")
findFirst :: [String] -> PreCST e s String -> PreCST e s String
findFirst [] PreCST e s String
err = PreCST e s String
err
findFirst (String
p:[String]
aths) PreCST e s String
err = do
Bool
e <- String -> PreCST e s Bool
forall e s. String -> PreCST e s Bool
doesFileExistCIO String
p
if Bool
e then String -> PreCST e s String
forall (m :: * -> *) a. Monad m => a -> m a
return String
p else [String] -> PreCST e s String -> PreCST e s String
findFirst [String]
aths PreCST e s String
err
dumpCHI :: String -> String -> CST s ()
dumpCHI :: String -> String -> CST s ()
dumpCHI String
fname String
contents =
do
(String
version, String
_, String
_) <- PreCST SwitchBoard s (String, String, String)
forall e s. PreCST e s (String, String, String)
getId
String -> String -> CST s ()
forall e s. String -> String -> PreCST e s ()
writeFileCIO (String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
chisuffix) (String -> CST s ()) -> String -> CST s ()
forall a b. (a -> b) -> a -> b
$
String
versionPrefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
version String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
contents
majorMinor :: String -> Maybe (String, String)
majorMinor :: String -> Maybe (String, String)
majorMinor String
vers = let (String
major, String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') String
vers
(String
minor, String
_ ) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') (String -> (String, String)) -> ShowS -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
tail (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ String
rest
in
if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rest then Maybe (String, String)
forall a. Maybe a
Nothing else (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
major, String
minor)
syntaxExc :: String
syntaxExc :: String
syntaxExc = String
"syntax"
ifError :: CST s a -> CST s a -> CST s a
ifError :: CST s a -> CST s a -> CST s a
ifError CST s a
action CST s a
handler = CST s a
action CST s a -> (String, String -> CST s a) -> CST s a
forall e s a.
PreCST e s a -> (String, String -> PreCST e s a) -> PreCST e s a
`catchExc` (String
syntaxExc, CST s a -> String -> CST s a
forall a b. a -> b -> a
const CST s a
handler)
raiseSyntaxError :: CST s a
raiseSyntaxError :: CST s a
raiseSyntaxError = String -> String -> CST s a
forall e s a. String -> String -> PreCST e s a
throwExc String
syntaxExc String
"syntax error"
parseCHSModule :: Position -> String -> CST s CHSModule
parseCHSModule :: Position -> String -> CST s CHSModule
parseCHSModule Position
pos String
cs = do
[CHSToken]
toks <- String -> Position -> CST s [CHSToken]
forall s. String -> Position -> CST s [CHSToken]
lexCHS String
cs Position
pos
[CHSFrag]
frags <- [CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
CHSModule -> CST s CHSModule
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CHSModule
CHSModule [CHSFrag]
frags)
parseFrags :: [CHSToken] -> CST s [CHSFrag]
parseFrags :: [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks = do
[CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags0 [CHSToken]
toks
CST s [CHSFrag] -> CST s [CHSFrag] -> CST s [CHSFrag]
forall s a. CST s a -> CST s a -> CST s a
`ifError` [CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
contFrags [CHSToken]
toks
where
parseFrags0 :: [CHSToken] -> CST s [CHSFrag]
parseFrags0 :: [CHSToken] -> CST s [CHSFrag]
parseFrags0 [] = [CHSFrag] -> CST s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return []
parseFrags0 (CHSTokHaskell Position
pos String
s:[CHSToken]
toks) = do
[CHSFrag]
frags <- [CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
[CHSFrag] -> CST s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CST s [CHSFrag]) -> [CHSFrag] -> CST s [CHSFrag]
forall a b. (a -> b) -> a -> b
$ String -> Position -> CHSFrag
CHSVerb String
s Position
pos CHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
: [CHSFrag]
frags
parseFrags0 (CHSTokCtrl Position
pos Char
c:[CHSToken]
toks) = do
[CHSFrag]
frags <- [CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
[CHSFrag] -> CST s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CST s [CHSFrag]) -> [CHSFrag] -> CST s [CHSFrag]
forall a b. (a -> b) -> a -> b
$ String -> Position -> CHSFrag
CHSVerb [Char
c] Position
pos CHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
: [CHSFrag]
frags
parseFrags0 (CHSTokCPP Position
pos String
s:[CHSToken]
toks) = do
[CHSFrag]
frags <- [CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
[CHSFrag] -> CST s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CST s [CHSFrag]) -> [CHSFrag] -> CST s [CHSFrag]
forall a b. (a -> b) -> a -> b
$ String -> Position -> CHSFrag
CHSCPP String
s Position
pos CHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
: [CHSFrag]
frags
parseFrags0 (CHSTokLine Position
pos :[CHSToken]
toks) = do
[CHSFrag]
frags <- [CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
[CHSFrag] -> CST s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CST s [CHSFrag]) -> [CHSFrag] -> CST s [CHSFrag]
forall a b. (a -> b) -> a -> b
$ Position -> CHSFrag
CHSLine Position
pos CHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
: [CHSFrag]
frags
parseFrags0 (CHSTokC Position
pos String
s:[CHSToken]
toks) = Position -> String -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> String -> [CHSToken] -> CST s [CHSFrag]
parseC Position
pos String
s [CHSToken]
toks
parseFrags0 (CHSTokImport Position
pos :[CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseImport Position
pos [CHSToken]
toks
parseFrags0 (CHSTokContext Position
pos :[CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseContext Position
pos [CHSToken]
toks
parseFrags0 (CHSTokType Position
pos :[CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseType Position
pos [CHSToken]
toks
parseFrags0 (CHSTokSizeof Position
pos :[CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseSizeof Position
pos [CHSToken]
toks
parseFrags0 (CHSTokEnum Position
pos :[CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseEnum Position
pos [CHSToken]
toks
parseFrags0 (CHSTokCall Position
pos :[CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseCall Position
pos [CHSToken]
toks
parseFrags0 (CHSTokFun Position
pos :[CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseFun Position
pos [CHSToken]
toks
parseFrags0 (CHSTokGet Position
pos :[CHSToken]
toks) = Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag]
parseField Position
pos CHSAccess
CHSGet [CHSToken]
toks
parseFrags0 (CHSTokSet Position
pos :[CHSToken]
toks) = Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag]
parseField Position
pos CHSAccess
CHSSet [CHSToken]
toks
parseFrags0 (CHSTokClass Position
pos :[CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseClass Position
pos [CHSToken]
toks
parseFrags0 (CHSTokPointer Position
pos :[CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parsePointer Position
pos [CHSToken]
toks
parseFrags0 (CHSTokPragma Position
pos :[CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parsePragma Position
pos [CHSToken]
toks
parseFrags0 [CHSToken]
toks = [CHSToken] -> CST s [CHSFrag]
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
contFrags :: [CHSToken] -> PreCST SwitchBoard s [CHSFrag]
contFrags [] = [CHSFrag] -> PreCST SwitchBoard s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return []
contFrags toks :: [CHSToken]
toks@(CHSTokHaskell Position
_ String
_:[CHSToken]
_ ) = [CHSToken] -> PreCST SwitchBoard s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
contFrags toks :: [CHSToken]
toks@(CHSTokCtrl Position
_ Char
_:[CHSToken]
_ ) = [CHSToken] -> PreCST SwitchBoard s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
contFrags (CHSToken
_ :[CHSToken]
toks) = [CHSToken] -> PreCST SwitchBoard s [CHSFrag]
contFrags [CHSToken]
toks
parseC :: Position -> String -> [CHSToken] -> CST s [CHSFrag]
parseC :: Position -> String -> [CHSToken] -> CST s [CHSFrag]
parseC Position
pos String
s [CHSToken]
toks =
do
[CHSFrag]
frags <- [CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
collectCtrlAndC [CHSToken]
toks
[CHSFrag] -> CST s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CST s [CHSFrag]) -> [CHSFrag] -> CST s [CHSFrag]
forall a b. (a -> b) -> a -> b
$ String -> Position -> CHSFrag
CHSC String
s Position
pos CHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
: [CHSFrag]
frags
where
collectCtrlAndC :: [CHSToken] -> PreCST SwitchBoard s [CHSFrag]
collectCtrlAndC (CHSTokCtrl Position
pos Char
c:[CHSToken]
toks) = do
[CHSFrag]
frags <- [CHSToken] -> PreCST SwitchBoard s [CHSFrag]
collectCtrlAndC [CHSToken]
toks
[CHSFrag] -> PreCST SwitchBoard s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> PreCST SwitchBoard s [CHSFrag])
-> [CHSFrag] -> PreCST SwitchBoard s [CHSFrag]
forall a b. (a -> b) -> a -> b
$ String -> Position -> CHSFrag
CHSC [Char
c] Position
pos CHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
: [CHSFrag]
frags
collectCtrlAndC (CHSTokC Position
pos String
s:[CHSToken]
toks) = do
[CHSFrag]
frags <- [CHSToken] -> PreCST SwitchBoard s [CHSFrag]
collectCtrlAndC [CHSToken]
toks
[CHSFrag] -> PreCST SwitchBoard s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> PreCST SwitchBoard s [CHSFrag])
-> [CHSFrag] -> PreCST SwitchBoard s [CHSFrag]
forall a b. (a -> b) -> a -> b
$ String -> Position -> CHSFrag
CHSC String
s Position
pos CHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
: [CHSFrag]
frags
collectCtrlAndC [CHSToken]
toks = [CHSToken] -> PreCST SwitchBoard s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
parseImport :: Position -> [CHSToken] -> CST s [CHSFrag]
parseImport :: Position -> [CHSToken] -> CST s [CHSFrag]
parseImport Position
pos [CHSToken]
toks = do
(Bool
qual, Ident
modid, [CHSToken]
toks') <-
case [CHSToken]
toks of
CHSTokIdent Position
_ Ident
ide :[CHSToken]
toks ->
let (Ident
ide', [CHSToken]
toks') = Ident -> [CHSToken] -> (Ident, [CHSToken])
rebuildModuleId Ident
ide [CHSToken]
toks
in (Bool, Ident, [CHSToken])
-> PreCST SwitchBoard s (Bool, Ident, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Ident
ide', [CHSToken]
toks')
CHSTokQualif Position
_: CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks ->
let (Ident
ide', [CHSToken]
toks') = Ident -> [CHSToken] -> (Ident, [CHSToken])
rebuildModuleId Ident
ide [CHSToken]
toks
in (Bool, Ident, [CHSToken])
-> PreCST SwitchBoard s (Bool, Ident, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True , Ident
ide', [CHSToken]
toks')
[CHSToken]
_ -> [CHSToken] -> PreCST SwitchBoard s (Bool, Ident, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
let fName :: String
fName = ShowS
moduleNameToFileName ShowS -> (Ident -> String) -> Ident -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> String
identToLexeme (Ident -> String) -> Ident -> String
forall a b. (a -> b) -> a -> b
$ Ident
modid
[CHSToken]
toks'' <- [CHSToken] -> CST s [CHSToken]
forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook [CHSToken]
toks'
[CHSFrag]
frags <- [CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks''
[CHSFrag] -> CST s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CST s [CHSFrag]) -> [CHSFrag] -> CST s [CHSFrag]
forall a b. (a -> b) -> a -> b
$ CHSHook -> CHSFrag
CHSHook (Bool -> Ident -> String -> Position -> CHSHook
CHSImport Bool
qual Ident
modid String
fName Position
pos) CHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
: [CHSFrag]
frags
rebuildModuleId :: Ident -> [CHSToken] -> (Ident, [CHSToken])
rebuildModuleId Ident
ide (CHSTokDot Position
_ : CHSTokIdent Position
_ Ident
ide' : [CHSToken]
toks) =
let catIdent :: Ident -> Ident -> Ident
catIdent Ident
ide Ident
ide' = Position -> String -> Ident
onlyPosIdent (Ident -> Position
forall a. Pos a => a -> Position
posOf Ident
ide)
(Ident -> String
identToLexeme Ident
ide String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
: Ident -> String
identToLexeme Ident
ide')
in Ident -> [CHSToken] -> (Ident, [CHSToken])
rebuildModuleId (Ident -> Ident -> Ident
catIdent Ident
ide Ident
ide') [CHSToken]
toks
rebuildModuleId Ident
ide [CHSToken]
toks = (Ident
ide, [CHSToken]
toks)
moduleNameToFileName :: String -> FilePath
moduleNameToFileName :: ShowS
moduleNameToFileName = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
dotToSlash
where dotToSlash :: Char -> Char
dotToSlash Char
'.' = Char
'/'
dotToSlash Char
c = Char
c
parseContext :: Position -> [CHSToken] -> CST s [CHSFrag]
parseContext :: Position -> [CHSToken] -> CST s [CHSFrag]
parseContext Position
pos [CHSToken]
toks = do
(Maybe String
olib , [CHSToken]
toks ) <- [CHSToken] -> CST s (Maybe String, [CHSToken])
forall s. [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptLib [CHSToken]
toks
(Maybe String
opref , [CHSToken]
toks) <- Bool -> [CHSToken] -> CST s (Maybe String, [CHSToken])
forall s. Bool -> [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptPrefix Bool
False [CHSToken]
toks
(Maybe String
olock , [CHSToken]
toks) <- [CHSToken] -> CST s (Maybe String, [CHSToken])
forall s. [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptLock [CHSToken]
toks
[CHSToken]
toks <- [CHSToken] -> CST s [CHSToken]
forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook [CHSToken]
toks
[CHSFrag]
frags <- [CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
let frag :: CHSHook
frag = Maybe String -> Maybe String -> Maybe String -> Position -> CHSHook
CHSContext Maybe String
olib Maybe String
opref Maybe String
olock Position
pos
[CHSFrag] -> CST s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CST s [CHSFrag]) -> [CHSFrag] -> CST s [CHSFrag]
forall a b. (a -> b) -> a -> b
$ CHSHook -> CHSFrag
CHSHook CHSHook
frag CHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
: [CHSFrag]
frags
parseType :: Position -> [CHSToken] -> CST s [CHSFrag]
parseType :: Position -> [CHSToken] -> CST s [CHSFrag]
parseType Position
pos (CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks) =
do
[CHSToken]
toks' <- [CHSToken] -> CST s [CHSToken]
forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook [CHSToken]
toks
[CHSFrag]
frags <- [CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks'
[CHSFrag] -> CST s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CST s [CHSFrag]) -> [CHSFrag] -> CST s [CHSFrag]
forall a b. (a -> b) -> a -> b
$ CHSHook -> CHSFrag
CHSHook (Ident -> Position -> CHSHook
CHSType Ident
ide Position
pos) CHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
: [CHSFrag]
frags
parseType Position
_ [CHSToken]
toks = [CHSToken] -> CST s [CHSFrag]
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseSizeof :: Position -> [CHSToken] -> CST s [CHSFrag]
parseSizeof :: Position -> [CHSToken] -> CST s [CHSFrag]
parseSizeof Position
pos (CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks) =
do
[CHSToken]
toks' <- [CHSToken] -> CST s [CHSToken]
forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook [CHSToken]
toks
[CHSFrag]
frags <- [CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks'
[CHSFrag] -> CST s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CST s [CHSFrag]) -> [CHSFrag] -> CST s [CHSFrag]
forall a b. (a -> b) -> a -> b
$ CHSHook -> CHSFrag
CHSHook (Ident -> Position -> CHSHook
CHSSizeof Ident
ide Position
pos) CHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
: [CHSFrag]
frags
parseSizeof Position
_ [CHSToken]
toks = [CHSToken] -> CST s [CHSFrag]
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseEnum :: Position -> [CHSToken] -> CST s [CHSFrag]
parseEnum :: Position -> [CHSToken] -> CST s [CHSFrag]
parseEnum Position
pos (CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks) =
do
(Maybe Ident
oalias, [CHSToken]
toks' ) <- Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken])
forall s.
Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken])
parseOptAs Ident
ide Bool
True [CHSToken]
toks
(CHSTrans
trans , [CHSToken]
toks'') <- [CHSToken] -> CST s (CHSTrans, [CHSToken])
forall s. [CHSToken] -> CST s (CHSTrans, [CHSToken])
parseTrans [CHSToken]
toks'
(Maybe String
oprefix, [CHSToken]
toks''') <- Bool -> [CHSToken] -> CST s (Maybe String, [CHSToken])
forall s. Bool -> [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptPrefix Bool
True [CHSToken]
toks''
([Ident]
derive, [CHSToken]
toks'''') <- [CHSToken] -> CST s ([Ident], [CHSToken])
forall s. [CHSToken] -> CST s ([Ident], [CHSToken])
parseDerive [CHSToken]
toks'''
[CHSToken]
toks''''' <- [CHSToken] -> CST s [CHSToken]
forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook [CHSToken]
toks''''
[CHSFrag]
frags <- [CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks'''''
[CHSFrag] -> CST s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CST s [CHSFrag]) -> [CHSFrag] -> CST s [CHSFrag]
forall a b. (a -> b) -> a -> b
$ CHSHook -> CHSFrag
CHSHook (Ident
-> Maybe Ident
-> CHSTrans
-> Maybe String
-> [Ident]
-> Position
-> CHSHook
CHSEnum Ident
ide (Maybe Ident -> Maybe Ident
norm Maybe Ident
oalias) CHSTrans
trans Maybe String
oprefix [Ident]
derive Position
pos) CHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
: [CHSFrag]
frags
where
norm :: Maybe Ident -> Maybe Ident
norm Maybe Ident
Nothing = Maybe Ident
forall a. Maybe a
Nothing
norm (Just Ident
ide') | Ident
ide Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
ide' = Maybe Ident
forall a. Maybe a
Nothing
| Bool
otherwise = Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
ide'
parseEnum Position
_ [CHSToken]
toks = [CHSToken] -> CST s [CHSFrag]
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseCall :: Position -> [CHSToken] -> CST s [CHSFrag]
parseCall :: Position -> [CHSToken] -> CST s [CHSFrag]
parseCall Position
pos [CHSToken]
toks =
do
(Bool
isPure , [CHSToken]
toks ) <- [CHSToken] -> CST s (Bool, [CHSToken])
forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsPure [CHSToken]
toks
(Bool
isUnsafe, [CHSToken]
toks ) <- [CHSToken] -> CST s (Bool, [CHSToken])
forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsUnsafe [CHSToken]
toks
(Bool
isNolock, [CHSToken]
toks ) <- [CHSToken] -> CST s (Bool, [CHSToken])
forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsNolock [CHSToken]
toks
(Ident
ide , [CHSToken]
toks ) <- [CHSToken] -> CST s (Ident, [CHSToken])
forall s. [CHSToken] -> CST s (Ident, [CHSToken])
parseIdent [CHSToken]
toks
(Maybe Ident
oalias , [CHSToken]
toks ) <- Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken])
forall s.
Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken])
parseOptAs Ident
ide Bool
False [CHSToken]
toks
[CHSToken]
toks <- [CHSToken] -> CST s [CHSToken]
forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook [CHSToken]
toks
[CHSFrag]
frags <- [CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
[CHSFrag] -> CST s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CST s [CHSFrag]) -> [CHSFrag] -> CST s [CHSFrag]
forall a b. (a -> b) -> a -> b
$
CHSHook -> CHSFrag
CHSHook (Bool -> Bool -> Bool -> Ident -> Maybe Ident -> Position -> CHSHook
CHSCall Bool
isPure Bool
isUnsafe Bool
isNolock Ident
ide (Ident -> Maybe Ident -> Maybe Ident
norm Ident
ide Maybe Ident
oalias) Position
pos) CHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
: [CHSFrag]
frags
parseFun :: Position -> [CHSToken] -> CST s [CHSFrag]
parseFun :: Position -> [CHSToken] -> CST s [CHSFrag]
parseFun Position
pos [CHSToken]
toks =
do
(Bool
isPure , [CHSToken]
toks' ) <- [CHSToken] -> CST s (Bool, [CHSToken])
forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsPure [CHSToken]
toks
(Bool
isUnsafe, [CHSToken]
toks'2) <- [CHSToken] -> CST s (Bool, [CHSToken])
forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsUnsafe [CHSToken]
toks'
(Bool
isNolock, [CHSToken]
toks'3) <- [CHSToken] -> CST s (Bool, [CHSToken])
forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsNolock [CHSToken]
toks'2
(Ident
ide , [CHSToken]
toks'4) <- [CHSToken] -> CST s (Ident, [CHSToken])
forall s. [CHSToken] -> CST s (Ident, [CHSToken])
parseIdent [CHSToken]
toks'3
(Maybe Ident
oalias , [CHSToken]
toks'5) <- Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken])
forall s.
Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken])
parseOptAs Ident
ide Bool
False [CHSToken]
toks'4
(Maybe String
octxt , [CHSToken]
toks'6) <- [CHSToken] -> PreCST SwitchBoard s (Maybe String, [CHSToken])
forall (m :: * -> *).
Monad m =>
[CHSToken] -> m (Maybe String, [CHSToken])
parseOptContext [CHSToken]
toks'5
([CHSParm]
parms , [CHSToken]
toks'7) <- [CHSToken] -> PreCST SwitchBoard s ([CHSParm], [CHSToken])
forall s.
[CHSToken] -> PreCST SwitchBoard s ([CHSParm], [CHSToken])
parseParms [CHSToken]
toks'6
(CHSParm
parm , [CHSToken]
toks'8) <- [CHSToken] -> CST s (CHSParm, [CHSToken])
forall s. [CHSToken] -> CST s (CHSParm, [CHSToken])
parseParm [CHSToken]
toks'7
[CHSToken]
toks'9 <- [CHSToken] -> CST s [CHSToken]
forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook [CHSToken]
toks'8
[CHSFrag]
frags <- [CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks'9
[CHSFrag] -> CST s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CST s [CHSFrag]) -> [CHSFrag] -> CST s [CHSFrag]
forall a b. (a -> b) -> a -> b
$
CHSHook -> CHSFrag
CHSHook
(Bool
-> Bool
-> Bool
-> Ident
-> Maybe Ident
-> Maybe String
-> [CHSParm]
-> CHSParm
-> Position
-> CHSHook
CHSFun Bool
isPure Bool
isUnsafe Bool
isNolock Ident
ide (Ident -> Maybe Ident -> Maybe Ident
norm Ident
ide Maybe Ident
oalias) Maybe String
octxt [CHSParm]
parms CHSParm
parm Position
pos) CHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
:
[CHSFrag]
frags
where
parseOptContext :: [CHSToken] -> m (Maybe String, [CHSToken])
parseOptContext (CHSTokHSVerb Position
_ String
ctxt:CHSTokDArrow Position
_:[CHSToken]
toks) =
(Maybe String, [CHSToken]) -> m (Maybe String, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
ctxt, [CHSToken]
toks)
parseOptContext [CHSToken]
toks =
(Maybe String, [CHSToken]) -> m (Maybe String, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
forall a. Maybe a
Nothing , [CHSToken]
toks)
parseParms :: [CHSToken] -> PreCST SwitchBoard s ([CHSParm], [CHSToken])
parseParms (CHSTokLBrace Position
_:CHSTokRBrace Position
_:CHSTokArrow Position
_:[CHSToken]
toks) =
([CHSParm], [CHSToken])
-> PreCST SwitchBoard s ([CHSParm], [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [CHSToken]
toks)
parseParms (CHSTokLBrace Position
_ :[CHSToken]
toks) =
[CHSToken] -> PreCST SwitchBoard s ([CHSParm], [CHSToken])
forall s.
[CHSToken] -> PreCST SwitchBoard s ([CHSParm], [CHSToken])
parseParms' (Position -> CHSToken
CHSTokComma Position
noposCHSToken -> [CHSToken] -> [CHSToken]
forall a. a -> [a] -> [a]
:[CHSToken]
toks)
parseParms [CHSToken]
toks =
[CHSToken] -> PreCST SwitchBoard s ([CHSParm], [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseParms' :: [CHSToken] -> PreCST SwitchBoard s ([CHSParm], [CHSToken])
parseParms' (CHSTokRBrace Position
_:CHSTokArrow Position
_:[CHSToken]
toks) = ([CHSParm], [CHSToken])
-> PreCST SwitchBoard s ([CHSParm], [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [CHSToken]
toks)
parseParms' (CHSTokComma Position
_ :[CHSToken]
toks) = do
(CHSParm
parm , [CHSToken]
toks' ) <- [CHSToken] -> CST s (CHSParm, [CHSToken])
forall s. [CHSToken] -> CST s (CHSParm, [CHSToken])
parseParm [CHSToken]
toks
([CHSParm]
parms, [CHSToken]
toks'') <- [CHSToken] -> PreCST SwitchBoard s ([CHSParm], [CHSToken])
parseParms' [CHSToken]
toks'
([CHSParm], [CHSToken])
-> PreCST SwitchBoard s ([CHSParm], [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (CHSParm
parmCHSParm -> [CHSParm] -> [CHSParm]
forall a. a -> [a] -> [a]
:[CHSParm]
parms, [CHSToken]
toks'')
parseParms' (CHSTokRBrace Position
_ :[CHSToken]
toks) = [CHSToken] -> PreCST SwitchBoard s ([CHSParm], [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseParms' [CHSToken]
toks = [CHSToken] -> PreCST SwitchBoard s ([CHSParm], [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseIsPure :: [CHSToken] -> CST s (Bool, [CHSToken])
parseIsPure :: [CHSToken] -> CST s (Bool, [CHSToken])
parseIsPure (CHSTokPure Position
_:[CHSToken]
toks) = (Bool, [CHSToken]) -> CST s (Bool, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True , [CHSToken]
toks)
parseIsPure (CHSTokFun Position
_:[CHSToken]
toks) = (Bool, [CHSToken]) -> CST s (Bool, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True , [CHSToken]
toks)
parseIsPure [CHSToken]
toks = (Bool, [CHSToken]) -> CST s (Bool, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [CHSToken]
toks)
parseIsUnsafe :: [CHSToken] -> CST s (Bool, [CHSToken])
parseIsUnsafe :: [CHSToken] -> CST s (Bool, [CHSToken])
parseIsUnsafe (CHSTokUnsafe Position
_:[CHSToken]
toks) = (Bool, [CHSToken]) -> CST s (Bool, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True , [CHSToken]
toks)
parseIsUnsafe [CHSToken]
toks = (Bool, [CHSToken]) -> CST s (Bool, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [CHSToken]
toks)
parseIsNolock :: [CHSToken] -> CST s (Bool, [CHSToken])
parseIsNolock :: [CHSToken] -> CST s (Bool, [CHSToken])
parseIsNolock (CHSTokNolock Position
_:[CHSToken]
toks) = (Bool, [CHSToken]) -> CST s (Bool, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True , [CHSToken]
toks)
parseIsNolock [CHSToken]
toks = (Bool, [CHSToken]) -> CST s (Bool, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [CHSToken]
toks)
norm :: Ident -> Maybe Ident -> Maybe Ident
norm :: Ident -> Maybe Ident -> Maybe Ident
norm Ident
ide Maybe Ident
Nothing = Maybe Ident
forall a. Maybe a
Nothing
norm Ident
ide (Just Ident
ide') | Ident
ide Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
ide' = Maybe Ident
forall a. Maybe a
Nothing
| Bool
otherwise = Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
ide'
parseParm :: [CHSToken] -> CST s (CHSParm, [CHSToken])
parseParm :: [CHSToken] -> CST s (CHSParm, [CHSToken])
parseParm [CHSToken]
toks =
do
(Maybe (Ident, CHSArg)
oimMarsh, [CHSToken]
toks' ) <- [CHSToken] -> CST s (Maybe (Ident, CHSArg), [CHSToken])
forall s. [CHSToken] -> CST s (Maybe (Ident, CHSArg), [CHSToken])
parseOptMarsh [CHSToken]
toks
(String
hsTyStr, Bool
twoCVals, Position
pos, [CHSToken]
toks'2) <-
case [CHSToken]
toks' of
(CHSTokHSVerb Position
pos String
hsTyStr:CHSTokAmp Position
_:[CHSToken]
toks'2) ->
(String, Bool, Position, [CHSToken])
-> PreCST SwitchBoard s (String, Bool, Position, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (String
hsTyStr, Bool
True , Position
pos, [CHSToken]
toks'2)
(CHSTokHSVerb Position
pos String
hsTyStr :[CHSToken]
toks'2) ->
(String, Bool, Position, [CHSToken])
-> PreCST SwitchBoard s (String, Bool, Position, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (String
hsTyStr, Bool
False, Position
pos, [CHSToken]
toks'2)
[CHSToken]
toks -> [CHSToken]
-> PreCST SwitchBoard s (String, Bool, Position, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
(Maybe (Ident, CHSArg)
oomMarsh, [CHSToken]
toks'3) <- [CHSToken] -> CST s (Maybe (Ident, CHSArg), [CHSToken])
forall s. [CHSToken] -> CST s (Maybe (Ident, CHSArg), [CHSToken])
parseOptMarsh [CHSToken]
toks'2
(CHSParm, [CHSToken]) -> CST s (CHSParm, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg)
-> String -> Bool -> Maybe (Ident, CHSArg) -> Position -> CHSParm
CHSParm Maybe (Ident, CHSArg)
oimMarsh String
hsTyStr Bool
twoCVals Maybe (Ident, CHSArg)
oomMarsh Position
pos, [CHSToken]
toks'3)
where
parseOptMarsh :: [CHSToken] -> CST s (Maybe (Ident, CHSArg), [CHSToken])
parseOptMarsh :: [CHSToken] -> CST s (Maybe (Ident, CHSArg), [CHSToken])
parseOptMarsh (CHSTokIdent Position
_ Ident
ide:CHSTokStar Position
_ :[CHSToken]
toks) =
(Maybe (Ident, CHSArg), [CHSToken])
-> CST s (Maybe (Ident, CHSArg), [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (Ident
ide, CHSArg
CHSIOArg) , [CHSToken]
toks)
parseOptMarsh (CHSTokIdent Position
_ Ident
ide:CHSTokMinus Position
_:[CHSToken]
toks) =
(Maybe (Ident, CHSArg), [CHSToken])
-> CST s (Maybe (Ident, CHSArg), [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (Ident
ide, CHSArg
CHSVoidArg), [CHSToken]
toks)
parseOptMarsh (CHSTokIdent Position
_ Ident
ide :[CHSToken]
toks) =
(Maybe (Ident, CHSArg), [CHSToken])
-> CST s (Maybe (Ident, CHSArg), [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (Ident
ide, CHSArg
CHSValArg) , [CHSToken]
toks)
parseOptMarsh [CHSToken]
toks =
(Maybe (Ident, CHSArg), [CHSToken])
-> CST s (Maybe (Ident, CHSArg), [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg)
forall a. Maybe a
Nothing, [CHSToken]
toks)
parseField :: Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag]
parseField :: Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag]
parseField Position
pos CHSAccess
access [CHSToken]
toks =
do
(CHSAPath
path, [CHSToken]
toks') <- [CHSToken] -> CST s (CHSAPath, [CHSToken])
forall s. [CHSToken] -> CST s (CHSAPath, [CHSToken])
parsePath [CHSToken]
toks
[CHSFrag]
frags <- [CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks'
[CHSFrag] -> CST s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CST s [CHSFrag]) -> [CHSFrag] -> CST s [CHSFrag]
forall a b. (a -> b) -> a -> b
$ CHSHook -> CHSFrag
CHSHook (CHSAccess -> CHSAPath -> Position -> CHSHook
CHSField CHSAccess
access CHSAPath
path Position
pos) CHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
: [CHSFrag]
frags
parsePointer :: Position -> [CHSToken] -> CST s [CHSFrag]
parsePointer :: Position -> [CHSToken] -> CST s [CHSFrag]
parsePointer Position
pos [CHSToken]
toks =
do
(Bool
isStar, Ident
ide, [CHSToken]
toks') <-
case [CHSToken]
toks of
CHSTokStar Position
_:CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks' -> (Bool, Ident, [CHSToken])
-> PreCST SwitchBoard s (Bool, Ident, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True , Ident
ide, [CHSToken]
toks')
CHSTokIdent Position
_ Ident
ide :[CHSToken]
toks' -> (Bool, Ident, [CHSToken])
-> PreCST SwitchBoard s (Bool, Ident, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Ident
ide, [CHSToken]
toks')
[CHSToken]
_ -> [CHSToken] -> PreCST SwitchBoard s (Bool, Ident, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
(Maybe Ident
oalias , [CHSToken]
toks'2) <- Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken])
forall s.
Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken])
parseOptAs Ident
ide Bool
True [CHSToken]
toks'
(CHSPtrType
ptrType, [CHSToken]
toks'3) <- [CHSToken] -> CST s (CHSPtrType, [CHSToken])
forall s. [CHSToken] -> CST s (CHSPtrType, [CHSToken])
parsePtrType [CHSToken]
toks'2
let
(Bool
isNewtype, Maybe Ident
oRefType, [CHSToken]
toks'4) =
case [CHSToken]
toks'3 of
CHSTokNewtype Position
_ :[CHSToken]
toks' -> (Bool
True , Maybe Ident
forall a. Maybe a
Nothing , [CHSToken]
toks' )
CHSTokArrow Position
_:CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks' -> (Bool
False, Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
ide, [CHSToken]
toks' )
[CHSToken]
_ -> (Bool
False, Maybe Ident
forall a. Maybe a
Nothing , [CHSToken]
toks'3)
[CHSToken]
toks'5 <- [CHSToken] -> CST s [CHSToken]
forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook [CHSToken]
toks'4
[CHSFrag]
frags <- [CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks'5
[CHSFrag] -> CST s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CST s [CHSFrag]) -> [CHSFrag] -> CST s [CHSFrag]
forall a b. (a -> b) -> a -> b
$
CHSHook -> CHSFrag
CHSHook
(Bool
-> Ident
-> Maybe Ident
-> CHSPtrType
-> Bool
-> Maybe Ident
-> Position
-> CHSHook
CHSPointer Bool
isStar Ident
ide (Ident -> Maybe Ident -> Maybe Ident
forall a. Eq a => a -> Maybe a -> Maybe a
norm Ident
ide Maybe Ident
oalias) CHSPtrType
ptrType Bool
isNewtype Maybe Ident
oRefType Position
pos)
CHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
: [CHSFrag]
frags
where
parsePtrType :: [CHSToken] -> CST s (CHSPtrType, [CHSToken])
parsePtrType :: [CHSToken] -> CST s (CHSPtrType, [CHSToken])
parsePtrType (CHSTokForeign Position
_:[CHSToken]
toks) = (CHSPtrType, [CHSToken]) -> CST s (CHSPtrType, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (CHSPtrType
CHSForeignPtr, [CHSToken]
toks)
parsePtrType (CHSTokStable Position
_ :[CHSToken]
toks) = (CHSPtrType, [CHSToken]) -> CST s (CHSPtrType, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (CHSPtrType
CHSStablePtr, [CHSToken]
toks)
parsePtrType [CHSToken]
toks = (CHSPtrType, [CHSToken]) -> CST s (CHSPtrType, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (CHSPtrType
CHSPtr, [CHSToken]
toks)
norm :: a -> Maybe a -> Maybe a
norm a
ide Maybe a
Nothing = Maybe a
forall a. Maybe a
Nothing
norm a
ide (Just a
ide') | a
ide a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
ide' = Maybe a
forall a. Maybe a
Nothing
| Bool
otherwise = a -> Maybe a
forall a. a -> Maybe a
Just a
ide'
parsePragma :: Position -> [CHSToken] -> CST s [CHSFrag]
parsePragma :: Position -> [CHSToken] -> CST s [CHSFrag]
parsePragma Position
pos [CHSToken]
toks = do
let
parseExts :: [String]
-> [CHSToken] -> PreCST SwitchBoard s ([String], [CHSToken])
parseExts [String]
exts (CHSTokIdent Position
_ Ident
ide:CHSTokComma Position
_:[CHSToken]
toks) =
[String]
-> [CHSToken] -> PreCST SwitchBoard s ([String], [CHSToken])
parseExts (Ident -> String
identToLexeme Ident
ideString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
exts) [CHSToken]
toks
parseExts [String]
exts (CHSTokIdent Position
_ Ident
ide:CHSTokPragEnd Position
_:[CHSToken]
toks) =
([String], [CHSToken])
-> PreCST SwitchBoard s ([String], [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> [String]
forall a. [a] -> [a]
reverse (Ident -> String
identToLexeme Ident
ideString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
exts), [CHSToken]
toks)
parseExts [String]
exts [CHSToken]
toks = [CHSToken] -> PreCST SwitchBoard s ([String], [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
([String]
exts, [CHSToken]
toks) <- [String]
-> [CHSToken] -> PreCST SwitchBoard s ([String], [CHSToken])
forall s.
[String]
-> [CHSToken] -> PreCST SwitchBoard s ([String], [CHSToken])
parseExts [] [CHSToken]
toks
[CHSFrag]
frags <- [CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
[CHSFrag] -> CST s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> Position -> CHSFrag
CHSLang [String]
exts Position
pos CHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
: [CHSFrag]
frags)
parseClass :: Position -> [CHSToken] -> CST s [CHSFrag]
parseClass :: Position -> [CHSToken] -> CST s [CHSFrag]
parseClass Position
pos (CHSTokIdent Position
_ Ident
sclassIde:
CHSTokDArrow Position
_ :
CHSTokIdent Position
_ Ident
classIde :
CHSTokIdent Position
_ Ident
typeIde :
[CHSToken]
toks) =
do
[CHSToken]
toks' <- [CHSToken] -> CST s [CHSToken]
forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook [CHSToken]
toks
[CHSFrag]
frags <- [CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks'
[CHSFrag] -> CST s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CST s [CHSFrag]) -> [CHSFrag] -> CST s [CHSFrag]
forall a b. (a -> b) -> a -> b
$ CHSHook -> CHSFrag
CHSHook (Maybe Ident -> Ident -> Ident -> Position -> CHSHook
CHSClass (Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
sclassIde) Ident
classIde Ident
typeIde Position
pos) CHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
: [CHSFrag]
frags
parseClass Position
pos (CHSTokIdent Position
_ Ident
classIde :
CHSTokIdent Position
_ Ident
typeIde :
[CHSToken]
toks) =
do
[CHSToken]
toks' <- [CHSToken] -> CST s [CHSToken]
forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook [CHSToken]
toks
[CHSFrag]
frags <- [CHSToken] -> CST s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks'
[CHSFrag] -> CST s [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CST s [CHSFrag]) -> [CHSFrag] -> CST s [CHSFrag]
forall a b. (a -> b) -> a -> b
$ CHSHook -> CHSFrag
CHSHook (Maybe Ident -> Ident -> Ident -> Position -> CHSHook
CHSClass Maybe Ident
forall a. Maybe a
Nothing Ident
classIde Ident
typeIde Position
pos) CHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
: [CHSFrag]
frags
parseClass Position
_ [CHSToken]
toks = [CHSToken] -> CST s [CHSFrag]
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseOptLib :: [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptLib :: [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptLib (CHSTokLib Position
_ :
CHSTokEqual Position
_ :
CHSTokString Position
_ String
str:
[CHSToken]
toks) = (Maybe String, [CHSToken]) -> CST s (Maybe String, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
str, [CHSToken]
toks)
parseOptLib (CHSTokLib Position
_:[CHSToken]
toks ) = [CHSToken] -> CST s (Maybe String, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseOptLib [CHSToken]
toks = (Maybe String, [CHSToken]) -> CST s (Maybe String, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
forall a. Maybe a
Nothing, [CHSToken]
toks)
parseOptLock :: [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptLock :: [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptLock (CHSTokLock Position
_ :
CHSTokEqual Position
_ :
CHSTokString Position
_ String
str:
[CHSToken]
toks) = (Maybe String, [CHSToken]) -> CST s (Maybe String, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
str, [CHSToken]
toks)
parseOptLock (CHSTokLock Position
_:[CHSToken]
toks ) = [CHSToken] -> CST s (Maybe String, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseOptLock [CHSToken]
toks = (Maybe String, [CHSToken]) -> CST s (Maybe String, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
forall a. Maybe a
Nothing, [CHSToken]
toks)
parseOptPrefix :: Bool -> [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptPrefix :: Bool -> [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptPrefix Bool
False (CHSTokPrefix Position
_ :
CHSTokEqual Position
_ :
CHSTokString Position
_ String
str:
[CHSToken]
toks) = (Maybe String, [CHSToken]) -> CST s (Maybe String, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
str, [CHSToken]
toks)
parseOptPrefix Bool
True (CHSTokWith Position
_ :
CHSTokPrefix Position
_ :
CHSTokEqual Position
_ :
CHSTokString Position
_ String
str:
[CHSToken]
toks) = (Maybe String, [CHSToken]) -> CST s (Maybe String, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
str, [CHSToken]
toks)
parseOptPrefix Bool
_ (CHSTokWith Position
_:[CHSToken]
toks) = [CHSToken] -> CST s (Maybe String, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseOptPrefix Bool
_ (CHSTokPrefix Position
_:[CHSToken]
toks) = [CHSToken] -> CST s (Maybe String, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseOptPrefix Bool
_ [CHSToken]
toks = (Maybe String, [CHSToken]) -> CST s (Maybe String, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
forall a. Maybe a
Nothing, [CHSToken]
toks)
parseOptAs :: Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken])
parseOptAs :: Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken])
parseOptAs Ident
_ Bool
_ (CHSTokAs Position
_:CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks) =
(Maybe Ident, [CHSToken]) -> CST s (Maybe Ident, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
ide, [CHSToken]
toks)
parseOptAs Ident
ide Bool
upper (CHSTokAs Position
_:CHSTokHat Position
pos :[CHSToken]
toks) =
(Maybe Ident, [CHSToken]) -> CST s (Maybe Ident, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident -> Maybe Ident
forall a. a -> Maybe a
Just (Ident -> Maybe Ident) -> Ident -> Maybe Ident
forall a b. (a -> b) -> a -> b
$ Ident -> Bool -> Position -> Ident
underscoreToCase Ident
ide Bool
upper Position
pos, [CHSToken]
toks)
parseOptAs Ident
_ Bool
_ (CHSTokAs Position
_ :[CHSToken]
toks) = [CHSToken] -> CST s (Maybe Ident, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseOptAs Ident
_ Bool
_ [CHSToken]
toks =
(Maybe Ident, [CHSToken]) -> CST s (Maybe Ident, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Ident
forall a. Maybe a
Nothing, [CHSToken]
toks)
underscoreToCase :: Ident -> Bool -> Position -> Ident
underscoreToCase :: Ident -> Bool -> Position -> Ident
underscoreToCase Ident
ide Bool
upper Position
pos =
let lexeme :: String
lexeme = Ident -> String
identToLexeme Ident
ide
ps :: [String]
ps = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
parts (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String
lexeme
in
Position -> String -> Ident
onlyPosIdent Position
pos (String -> Ident) -> ([String] -> String) -> [String] -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
adjustHead ShowS -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
adjustCase ([String] -> Ident) -> [String] -> Ident
forall a b. (a -> b) -> a -> b
$ [String]
ps
where
parts :: String -> [String]
parts String
s = let (String
l, String
s') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') String
s
in
String
l String -> [String] -> [String]
forall a. a -> [a] -> [a]
: case String
s' of
[] -> []
(Char
_:String
s'') -> String -> [String]
parts String
s''
adjustCase :: ShowS
adjustCase (Char
c:String
cs) = Char -> Char
toUpper Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
cs
adjustHead :: ShowS
adjustHead String
"" = String
""
adjustHead (Char
c:String
cs) = if Bool
upper then Char -> Char
toUpper Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
cs else Char -> Char
toLower Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
cs
parsePath :: [CHSToken] -> CST s (CHSAPath, [CHSToken])
parsePath :: [CHSToken] -> CST s (CHSAPath, [CHSToken])
parsePath (CHSTokStar Position
pos:[CHSToken]
toks) =
do
(CHSAPath
path, [CHSToken]
toks') <- [CHSToken] -> CST s (CHSAPath, [CHSToken])
forall s. [CHSToken] -> CST s (CHSAPath, [CHSToken])
parsePath [CHSToken]
toks
(CHSAPath, [CHSToken]) -> CST s (CHSAPath, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (CHSAPath -> Position -> CHSAPath
CHSDeref CHSAPath
path Position
pos, [CHSToken]
toks')
parsePath (CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks) =
do
(CHSAPath -> CHSAPath
pathWithHole, [CHSToken]
toks') <- [CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])
forall s. [CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])
parsePath' [CHSToken]
toks
(CHSAPath, [CHSToken]) -> CST s (CHSAPath, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (CHSAPath -> CHSAPath
pathWithHole (Ident -> CHSAPath
CHSRoot Ident
ide), [CHSToken]
toks')
parsePath [CHSToken]
toks = [CHSToken] -> CST s (CHSAPath, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parsePath' :: [CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])
parsePath' :: [CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])
parsePath' (CHSTokDot Position
_:CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks) =
do
(CHSAPath -> CHSAPath
pathWithHole, [CHSToken]
toks') <- [CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])
forall s. [CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])
parsePath' [CHSToken]
toks
(CHSAPath -> CHSAPath, [CHSToken])
-> CST s (CHSAPath -> CHSAPath, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (CHSAPath -> CHSAPath
pathWithHole (CHSAPath -> CHSAPath)
-> (CHSAPath -> CHSAPath) -> CHSAPath -> CHSAPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\CHSAPath
hole -> CHSAPath -> Ident -> CHSAPath
CHSRef CHSAPath
hole Ident
ide), [CHSToken]
toks')
parsePath' (CHSTokDot Position
_:[CHSToken]
toks) =
[CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parsePath' (CHSTokArrow Position
pos:CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks) =
do
(CHSAPath -> CHSAPath
pathWithHole, [CHSToken]
toks') <- [CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])
forall s. [CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])
parsePath' [CHSToken]
toks
(CHSAPath -> CHSAPath, [CHSToken])
-> CST s (CHSAPath -> CHSAPath, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (CHSAPath -> CHSAPath
pathWithHole (CHSAPath -> CHSAPath)
-> (CHSAPath -> CHSAPath) -> CHSAPath -> CHSAPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\CHSAPath
hole -> CHSAPath -> Ident -> CHSAPath
CHSRef (CHSAPath -> Position -> CHSAPath
CHSDeref CHSAPath
hole Position
pos) Ident
ide), [CHSToken]
toks')
parsePath' (CHSTokArrow Position
_:[CHSToken]
toks) =
[CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parsePath' [CHSToken]
toks =
do
[CHSToken]
toks' <- [CHSToken] -> CST s [CHSToken]
forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook [CHSToken]
toks
(CHSAPath -> CHSAPath, [CHSToken])
-> CST s (CHSAPath -> CHSAPath, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (CHSAPath -> CHSAPath
forall a. a -> a
id, [CHSToken]
toks')
parseTrans :: [CHSToken] -> CST s (CHSTrans, [CHSToken])
parseTrans :: [CHSToken] -> CST s (CHSTrans, [CHSToken])
parseTrans (CHSTokLBrace Position
_:[CHSToken]
toks) =
do
(Bool
_2Case, [CHSToken]
toks' ) <- [CHSToken] -> PreCST SwitchBoard s (Bool, [CHSToken])
forall (m :: * -> *). Monad m => [CHSToken] -> m (Bool, [CHSToken])
parse_2Case [CHSToken]
toks
case [CHSToken]
toks' of
(CHSTokRBrace Position
_:[CHSToken]
toks'') -> (CHSTrans, [CHSToken]) -> CST s (CHSTrans, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> [(Ident, Ident)] -> CHSTrans
CHSTrans Bool
_2Case [], [CHSToken]
toks'')
[CHSToken]
_ ->
do
([(Ident, Ident)]
transs, [CHSToken]
toks'') <- if Bool
_2Case
then [CHSToken] -> PreCST SwitchBoard s ([(Ident, Ident)], [CHSToken])
forall s.
[CHSToken] -> PreCST SwitchBoard s ([(Ident, Ident)], [CHSToken])
parseTranss [CHSToken]
toks'
else [CHSToken] -> PreCST SwitchBoard s ([(Ident, Ident)], [CHSToken])
forall s.
[CHSToken] -> PreCST SwitchBoard s ([(Ident, Ident)], [CHSToken])
parseTranss (Position -> CHSToken
CHSTokComma Position
noposCHSToken -> [CHSToken] -> [CHSToken]
forall a. a -> [a] -> [a]
:[CHSToken]
toks')
(CHSTrans, [CHSToken]) -> CST s (CHSTrans, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> [(Ident, Ident)] -> CHSTrans
CHSTrans Bool
_2Case [(Ident, Ident)]
transs, [CHSToken]
toks'')
where
parse_2Case :: [CHSToken] -> m (Bool, [CHSToken])
parse_2Case (CHSTok_2Case Position
_:[CHSToken]
toks) = (Bool, [CHSToken]) -> m (Bool, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, [CHSToken]
toks)
parse_2Case [CHSToken]
toks = (Bool, [CHSToken]) -> m (Bool, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [CHSToken]
toks)
parseTranss :: [CHSToken] -> PreCST SwitchBoard s ([(Ident, Ident)], [CHSToken])
parseTranss (CHSTokRBrace Position
_:[CHSToken]
toks) = ([(Ident, Ident)], [CHSToken])
-> PreCST SwitchBoard s ([(Ident, Ident)], [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [CHSToken]
toks)
parseTranss (CHSTokComma Position
_:[CHSToken]
toks) = do
((Ident, Ident)
assoc, [CHSToken]
toks' ) <- [CHSToken] -> PreCST SwitchBoard s ((Ident, Ident), [CHSToken])
forall s.
[CHSToken] -> PreCST SwitchBoard s ((Ident, Ident), [CHSToken])
parseAssoc [CHSToken]
toks
([(Ident, Ident)]
trans, [CHSToken]
toks'') <- [CHSToken] -> PreCST SwitchBoard s ([(Ident, Ident)], [CHSToken])
parseTranss [CHSToken]
toks'
([(Ident, Ident)], [CHSToken])
-> PreCST SwitchBoard s ([(Ident, Ident)], [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Ident, Ident)
assoc(Ident, Ident) -> [(Ident, Ident)] -> [(Ident, Ident)]
forall a. a -> [a] -> [a]
:[(Ident, Ident)]
trans, [CHSToken]
toks'')
parseTranss [CHSToken]
toks = [CHSToken] -> PreCST SwitchBoard s ([(Ident, Ident)], [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseAssoc :: [CHSToken] -> PreCST SwitchBoard s ((Ident, Ident), [CHSToken])
parseAssoc (CHSTokIdent Position
_ Ident
ide1:CHSTokAs Position
_:CHSTokIdent Position
_ Ident
ide2:[CHSToken]
toks) =
((Ident, Ident), [CHSToken])
-> PreCST SwitchBoard s ((Ident, Ident), [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Ident
ide1, Ident
ide2), [CHSToken]
toks)
parseAssoc (CHSTokIdent Position
_ Ident
ide1:CHSTokAs Position
_:[CHSToken]
toks ) =
[CHSToken] -> PreCST SwitchBoard s ((Ident, Ident), [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseAssoc (CHSTokIdent Position
_ Ident
ide1:[CHSToken]
toks ) =
[CHSToken] -> PreCST SwitchBoard s ((Ident, Ident), [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseAssoc [CHSToken]
toks =
[CHSToken] -> PreCST SwitchBoard s ((Ident, Ident), [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseTrans [CHSToken]
toks = [CHSToken] -> CST s (CHSTrans, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseDerive :: [CHSToken] -> CST s ([Ident], [CHSToken])
parseDerive :: [CHSToken] -> CST s ([Ident], [CHSToken])
parseDerive (CHSTokDerive Position
_ :CHSTokLParen Position
_:CHSTokRParen Position
_:[CHSToken]
toks) =
([Ident], [CHSToken]) -> CST s ([Ident], [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [CHSToken]
toks)
parseDerive (CHSTokDerive Position
_ :CHSTokLParen Position
_:[CHSToken]
toks) =
[CHSToken] -> CST s ([Ident], [CHSToken])
forall s. [CHSToken] -> CST s ([Ident], [CHSToken])
parseCommaIdent (Position -> CHSToken
CHSTokComma Position
noposCHSToken -> [CHSToken] -> [CHSToken]
forall a. a -> [a] -> [a]
:[CHSToken]
toks)
where
parseCommaIdent :: [CHSToken] -> CST s ([Ident], [CHSToken])
parseCommaIdent :: [CHSToken] -> CST s ([Ident], [CHSToken])
parseCommaIdent (CHSTokComma Position
_:CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks) =
do
([Ident]
ids, [CHSToken]
tok') <- [CHSToken] -> CST s ([Ident], [CHSToken])
forall s. [CHSToken] -> CST s ([Ident], [CHSToken])
parseCommaIdent [CHSToken]
toks
([Ident], [CHSToken]) -> CST s ([Ident], [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
ideIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
ids, [CHSToken]
tok')
parseCommaIdent (CHSTokRParen Position
_ :[CHSToken]
toks) =
([Ident], [CHSToken]) -> CST s ([Ident], [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [CHSToken]
toks)
parseDerive [CHSToken]
toks = ([Ident], [CHSToken]) -> CST s ([Ident], [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return ([],[CHSToken]
toks)
parseIdent :: [CHSToken] -> CST s (Ident, [CHSToken])
parseIdent :: [CHSToken] -> CST s (Ident, [CHSToken])
parseIdent (CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks) = (Ident, [CHSToken]) -> CST s (Ident, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
ide, [CHSToken]
toks)
parseIdent [CHSToken]
toks = [CHSToken] -> CST s (Ident, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseEndHook :: [CHSToken] -> CST s ([CHSToken])
parseEndHook :: [CHSToken] -> CST s [CHSToken]
parseEndHook (CHSTokEndHook Position
_:[CHSToken]
toks) = [CHSToken] -> CST s [CHSToken]
forall (m :: * -> *) a. Monad m => a -> m a
return [CHSToken]
toks
parseEndHook [CHSToken]
toks = [CHSToken] -> CST s [CHSToken]
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
syntaxError :: [CHSToken] -> CST s a
syntaxError :: [CHSToken] -> CST s a
syntaxError [] = CST s a
forall s a. CST s a
errorEOF
syntaxError (CHSToken
tok:[CHSToken]
_) = CHSToken -> CST s a
forall s a. CHSToken -> CST s a
errorIllegal CHSToken
tok
errorIllegal :: CHSToken -> CST s a
errorIllegal :: CHSToken -> CST s a
errorIllegal CHSToken
tok = do
Position -> [String] -> PreCST SwitchBoard s ()
forall e s. Position -> [String] -> PreCST e s ()
raiseError (CHSToken -> Position
forall a. Pos a => a -> Position
posOf CHSToken
tok)
[String
"Syntax error!",
String
"The phrase `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CHSToken -> String
forall a. Show a => a -> String
show CHSToken
tok String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' is not allowed \
\here."]
CST s a
forall s a. CST s a
raiseSyntaxError
errorEOF :: CST s a
errorEOF :: CST s a
errorEOF = do
Position -> [String] -> PreCST SwitchBoard s ()
forall e s. Position -> [String] -> PreCST e s ()
raiseError Position
nopos
[String
"Premature end of file!",
String
"The .chs file ends in the middle of a binding hook."]
CST s a
forall s a. CST s a
raiseSyntaxError
errorCHINotFound :: String -> CST s a
errorCHINotFound :: String -> CST s a
errorCHINotFound String
ide = do
Position -> [String] -> PreCST SwitchBoard s ()
forall e s. Position -> [String] -> PreCST e s ()
raiseError Position
nopos
[String
"Unknown .chi file!",
String
"Cannot find the .chi file for `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ide String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'."]
CST s a
forall s a. CST s a
raiseSyntaxError
errorCHICorrupt :: String -> CST s a
errorCHICorrupt :: String -> CST s a
errorCHICorrupt String
ide = do
Position -> [String] -> PreCST SwitchBoard s ()
forall e s. Position -> [String] -> PreCST e s ()
raiseError Position
nopos
[String
"Corrupt .chi file!",
String
"The file `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ide String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".chi' is corrupt."]
CST s a
forall s a. CST s a
raiseSyntaxError
errorCHIVersion :: String -> String -> String -> CST s a
errorCHIVersion :: String -> String -> String -> CST s a
errorCHIVersion String
ide String
chiVersion String
myVersion = do
Position -> [String] -> PreCST SwitchBoard s ()
forall e s. Position -> [String] -> PreCST e s ()
raiseError Position
nopos
[String
"Wrong version of .chi file!",
String
"The file `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ide String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".chi' is version "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
chiVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", but mine is " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
myVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."]
CST s a
forall s a. CST s a
raiseSyntaxError