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 _ pos :: Position
pos ) = Position
pos
posOf (CHSHook hook :: CHSHook
hook ) = CHSHook -> Position
forall a. Pos a => a -> Position
posOf CHSHook
hook
posOf (CHSCPP _ pos :: Position
pos ) = Position
pos
posOf (CHSLine pos :: Position
pos ) = Position
pos
posOf (CHSC _ pos :: Position
pos ) = Position
pos
posOf (CHSCond alts :: [(Ident, [CHSFrag])]
alts _) = case [(Ident, [CHSFrag])]
alts of
(_, frag :: CHSFrag
frag:_):_ -> CHSFrag -> Position
forall a. Pos a => a -> Position
posOf CHSFrag
frag
_ -> Position
nopos
posOf (CHSLang _ pos :: 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 _ _ _ pos :: Position
pos) = Position
pos
posOf (CHSContext _ _ _ pos :: Position
pos) = Position
pos
posOf (CHSType _ pos :: Position
pos) = Position
pos
posOf (CHSSizeof _ pos :: Position
pos) = Position
pos
posOf (CHSEnum _ _ _ _ _ pos :: Position
pos) = Position
pos
posOf (CHSCall _ _ _ _ _ pos :: Position
pos) = Position
pos
posOf (CHSFun _ _ _ _ _ _ _ _ pos :: Position
pos) = Position
pos
posOf (CHSField _ _ pos :: Position
pos) = Position
pos
posOf (CHSPointer _ _ _ _ _ _ pos :: Position
pos) = Position
pos
posOf (CHSClass _ _ _ pos :: Position
pos) = Position
pos
instance Eq CHSHook where
(CHSImport qual1 :: Bool
qual1 ide1 :: Ident
ide1 _ _) == :: CHSHook -> CHSHook -> Bool
== (CHSImport qual2 :: Bool
qual2 ide2 :: Ident
ide2 _ _) =
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 olib1 :: Maybe String
olib1 opref1 :: Maybe String
opref1 olock1 :: Maybe String
olock1 _ ) ==
(CHSContext olib2 :: Maybe String
olib2 opref2 :: Maybe String
opref2 olock2 :: Maybe String
olock2 _ ) =
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 ide1 :: Ident
ide1 _) == (CHSType ide2 :: Ident
ide2 _) =
Ident
ide1 Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
ide2
(CHSSizeof ide1 :: Ident
ide1 _) == (CHSSizeof ide2 :: Ident
ide2 _) =
Ident
ide1 Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
ide2
(CHSEnum ide1 :: Ident
ide1 oalias1 :: Maybe Ident
oalias1 _ _ _ _) == (CHSEnum ide2 :: Ident
ide2 oalias2 :: Maybe Ident
oalias2 _ _ _ _) =
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 _ _ _ ide1 :: Ident
ide1 oalias1 :: Maybe Ident
oalias1 _) == (CHSCall _ _ _ ide2 :: Ident
ide2 oalias2 :: Maybe Ident
oalias2 _) =
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 _ _ _ ide1 :: Ident
ide1 oalias1 :: Maybe Ident
oalias1 _ _ _ _)
== (CHSFun _ _ _ ide2 :: Ident
ide2 oalias2 :: Maybe Ident
oalias2 _ _ _ _) =
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 acc1 :: CHSAccess
acc1 path1 :: CHSAPath
path1 _) == (CHSField acc2 :: CHSAccess
acc2 path2 :: CHSAPath
path2 _) =
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 _ ide1 :: Ident
ide1 oalias1 :: Maybe Ident
oalias1 _ _ _ _)
== (CHSPointer _ ide2 :: Ident
ide2 oalias2 :: Maybe Ident
oalias2 _ _ _ _) =
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 _ ide1 :: Ident
ide1 _ _) == (CHSClass _ ide2 :: Ident
ide2 _ _) =
Ident
ide1 Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
ide2
_ == _ = 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 CHSPtr = "Ptr"
show CHSForeignPtr = "ForeignPtr"
show CHSStablePtr = "StablePtr"
instance Read CHSPtrType where
readsPrec :: Int -> ReadS CHSPtrType
readsPrec _ ( 'P':'t':'r':rest :: String
rest) =
[(CHSPtrType
CHSPtr, String
rest)]
readsPrec _ ('F':'o':'r':'e':'i':'g':'n':'P':'t':'r':rest :: String
rest) =
[(CHSPtrType
CHSForeignPtr, String
rest)]
readsPrec _ ('S':'t':'a':'b':'l':'e' :'P':'t':'r':rest :: String
rest) =
[(CHSPtrType
CHSStablePtr, String
rest)]
readsPrec p :: Int
p (c :: Char
c:cs :: String
cs)
| Char -> Bool
isSpace Char
c = Int -> ReadS CHSPtrType
forall a. Read a => Int -> ReadS a
readsPrec Int
p String
cs
readsPrec _ _ = []
skipToLangPragma :: CHSModule -> Maybe CHSModule
skipToLangPragma :: CHSModule -> Maybe CHSModule
skipToLangPragma (CHSModule frags :: [CHSFrag]
frags) = [CHSFrag] -> Maybe CHSModule
hLP [CHSFrag]
frags
where
hLP :: [CHSFrag] -> Maybe CHSModule
hLP all :: [CHSFrag]
all@(CHSLang exts :: [String]
exts _:_) = CHSModule -> Maybe CHSModule
forall a. a -> Maybe a
Just ([CHSFrag] -> CHSModule
CHSModule [CHSFrag]
all)
hLP (x :: CHSFrag
x:xs :: [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 exts :: [String]
exts _:_)) = "CPP" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
exts
hasCPP _ = Bool
False
hssuffix, chssuffix :: String
hssuffix :: String
hssuffix = ".hs"
chssuffix :: String
chssuffix = ".chs"
loadCHS :: FilePath -> CST s (CHSModule, String)
loadCHS :: String -> CST s (CHSModule, String)
loadCHS fname :: 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 1 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 ("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 fname :: String
fname = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
("Attempting to read file `"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ "'...\n")
traceInfoParse :: CST s ()
traceInfoParse = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
("...parsing `"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ "'...\n")
traceInfoErr :: CST s ()
traceInfoErr = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
("...error(s) detected in `"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ "'.\n")
traceInfoOK :: CST s ()
traceInfoOK = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
("...successfully loaded `"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ "'.\n")
dumpCHS :: String -> CHSModule -> Bool -> CST s ()
dumpCHS :: String -> CHSModule -> Bool -> CST s ()
dumpCHS fname :: String
fname mod :: CHSModule
mod pureHaskell :: Bool
pureHaskell =
do
let (suffix :: String
suffix, kind :: String
kind) = if Bool
pureHaskell
then (String
hssuffix , "(Haskell)")
else (String
chssuffix, "(C->HS binding)")
(version :: String
version, _, _) <- 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 version :: String
version kind :: String
kind | CHSModule -> Bool
hasCPP CHSModule
mod = CHSModule -> Bool -> String
showCHSModule CHSModule
mod Bool
pureHaskell
| Bool
otherwise =
"-- GENERATED by " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
version String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
kind String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\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 frags :: [CHSFrag]
frags) pureHaskell :: 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 _ _ [] = ShowS
forall a. a -> a
id
showFrags pureHs :: Bool
pureHs state :: LineState
state (CHSVerb s :: String
s pos :: Position
pos : frags :: [CHSFrag]
frags) =
let
(Position fname :: String
fname line :: Int
line _) = 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
== '\n'
nextState :: LineState
nextState = if Bool
generated then LineState
Wait else LineState
NoLine
in
(if Bool
emitNow then
String -> ShowS
showString ("\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` 0) String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " 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 -> ShowS
forall a. [a] -> [a] -> [a]
++
(if Bool
nlStart then "" else "\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 False _ (CHSHook hook :: CHSHook
hook : frags :: [CHSFrag]
frags) =
String -> ShowS
showString "{#"
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 "#}"
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 False _ (CHSCPP s :: String
s _ : frags :: [CHSFrag]
frags) =
Char -> ShowS
showChar '#'
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 pureHs :: Bool
pureHs _ (CHSLine s :: Position
s : frags :: [CHSFrag]
frags) =
Bool -> LineState -> [CHSFrag] -> ShowS
showFrags Bool
pureHs LineState
Emit [CHSFrag]
frags
showFrags False _ (CHSC s :: String
s _ : frags :: [CHSFrag]
frags) =
String -> ShowS
showString "\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 "\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 False _ (CHSCond _ _ : frags :: [CHSFrag]
frags) =
String -> ShowS
forall a. String -> a
interr "showCHSFrag: Cannot print `CHSCond'!"
showFrags pureHs :: Bool
pureHs _ (CHSLang exts :: [String]
exts _ : frags :: [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
(/=) "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 "{-# 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]
extsNoCPP))
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " #-}\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 True _ _ =
String -> ShowS
forall a. String -> a
interr "showCHSFrag: Illegal hook, cpp directive, or inline C code!"
showCHSHook :: CHSHook -> ShowS
showCHSHook :: CHSHook -> ShowS
showCHSHook (CHSImport isQual :: Bool
isQual ide :: Ident
ide _ _) =
String -> ShowS
showString "import "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isQual then String -> ShowS
showString "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 olib :: Maybe String
olib oprefix :: Maybe String
oprefix olock :: Maybe String
olock _) =
String -> ShowS
showString "context "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case Maybe String
olib of
Nothing -> String -> ShowS
showString ""
Just lib :: String
lib -> String -> ShowS
showString "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 " ")
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
Nothing -> String -> ShowS
showString ""
Just lock :: String
lock -> String -> ShowS
showString "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 " ")
showCHSHook (CHSType ide :: Ident
ide _) =
String -> ShowS
showString "type "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide
showCHSHook (CHSSizeof ide :: Ident
ide _) =
String -> ShowS
showString "sizeof "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide
showCHSHook (CHSEnum ide :: Ident
ide oalias :: Maybe Ident
oalias trans :: CHSTrans
trans oprefix :: Maybe String
oprefix derive :: [Ident]
derive _) =
String -> ShowS
showString "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
$
"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 ", " ((Ident -> String) -> [Ident] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> String
identToLexeme [Ident]
derive))
String -> ShowS
forall a. [a] -> [a] -> [a]
++ ") "
showCHSHook (CHSCall isPure :: Bool
isPure isUns :: Bool
isUns isNol :: Bool
isNol ide :: Ident
ide oalias :: Maybe Ident
oalias _) =
String -> ShowS
showString "call "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isPure then String -> ShowS
showString "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 "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 "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 isPure :: Bool
isPure isUns :: Bool
isUns isNol :: Bool
isNol ide :: Ident
ide oalias :: Maybe Ident
oalias octxt :: Maybe String
octxt parms :: [CHSParm]
parms parm :: CHSParm
parm _) =
String -> ShowS
showString "fun "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isPure then String -> ShowS
showString "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 "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 "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
Nothing -> Char -> ShowS
showChar ' '
Just ctxtStr :: String
ctxtStr -> String -> ShowS
showString String
ctxtStr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " => ")
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "{"
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 ", ") ((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 "} -> "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CHSParm -> ShowS
showCHSParm CHSParm
parm
showCHSHook (CHSField acc :: CHSAccess
acc path :: CHSAPath
path _) =
(case CHSAccess
acc of
CHSGet -> String -> ShowS
showString "get "
CHSSet -> String -> ShowS
showString "set ")
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CHSAPath -> ShowS
showCHSAPath CHSAPath
path
showCHSHook (CHSPointer star :: Bool
star ide :: Ident
ide oalias :: Maybe Ident
oalias ptrType :: CHSPtrType
ptrType isNewtype :: Bool
isNewtype oRefType :: Maybe Ident
oRefType _) =
String -> ShowS
showString "pointer "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
star then String -> ShowS
showString "*" else String -> ShowS
showString "")
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
CHSForeignPtr -> String -> ShowS
showString " foreign"
CHSStablePtr -> String -> ShowS
showString " stable"
_ -> String -> ShowS
showString "")
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case (Bool
isNewtype, Maybe Ident
oRefType) of
(True , _ ) -> String -> ShowS
showString " newtype"
(False, Just ide :: Ident
ide) -> String -> ShowS
showString " -> " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide
(False, Nothing ) -> String -> ShowS
showString "")
showCHSHook (CHSClass oclassIde :: Maybe Ident
oclassIde classIde :: Ident
classIde typeIde :: Ident
typeIde _) =
String -> ShowS
showString "class "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case Maybe Ident
oclassIde of
Nothing -> String -> ShowS
showString ""
Just classIde :: Ident
classIde -> Ident -> ShowS
showCHSIdent Ident
classIde ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " => ")
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 " "
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 Nothing _ = String -> ShowS
showString ""
showPrefix (Just prefix :: String
prefix) withWith :: Bool
withWith = ShowS
maybeWith
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "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 " "
where
maybeWith :: ShowS
maybeWith = if Bool
withWith then String -> ShowS
showString "with " else ShowS
forall a. a -> a
id
showIdAlias :: Ident -> Maybe Ident -> ShowS
showIdAlias :: Ident -> Maybe Ident -> ShowS
showIdAlias ide :: Ident
ide oalias :: 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
Nothing -> ShowS
forall a. a -> a
id
Just ide :: Ident
ide -> String -> ShowS
showString " 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 oimMarsh :: Maybe (Ident, CHSArg)
oimMarsh hsTyStr :: String
hsTyStr twoCVals :: Bool
twoCVals oomMarsh :: Maybe (Ident, CHSArg)
oomMarsh _) =
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 ' '
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 '&' else ShowS
forall a. a -> a
id)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar ' '
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 Nothing = ShowS
forall a. a -> a
id
showOMarsh (Just (ide :: Ident
ide, argKind :: CHSArg
argKind)) = Ident -> ShowS
showCHSIdent Ident
ide
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case CHSArg
argKind of
CHSValArg -> ShowS
forall a. a -> a
id
CHSIOArg -> String -> ShowS
showString "*"
CHSVoidArg -> String -> ShowS
showString "-")
showHsVerb :: String -> ShowS
showHsVerb str :: String
str = Char -> ShowS
showChar '`' 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 '\''
showCHSTrans :: CHSTrans -> ShowS
showCHSTrans :: CHSTrans -> ShowS
showCHSTrans (CHSTrans _2Case :: Bool
_2Case assocs :: [(Ident, Ident)]
assocs) =
String -> ShowS
showString "{"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
_2Case then String -> ShowS
showString ("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 ", ") (((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 "}"
where
maybeComma :: String
maybeComma = if [(Ident, Ident)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Ident, Ident)]
assocs then "" else ", "
showAssoc :: (Ident, Ident) -> ShowS
showAssoc (ide1 :: Ident
ide1, ide2 :: Ident
ide2) =
Ident -> ShowS
showCHSIdent Ident
ide1
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " 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 ide :: Ident
ide) =
Ident -> ShowS
showCHSIdent Ident
ide
showCHSAPath (CHSDeref path :: CHSAPath
path _) =
String -> ShowS
showString "* "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CHSAPath -> ShowS
showCHSAPath CHSAPath
path
showCHSAPath (CHSRef (CHSDeref path :: CHSAPath
path _) ide :: Ident
ide) =
CHSAPath -> ShowS
showCHSAPath CHSAPath
path
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "->"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide
showCHSAPath (CHSRef path :: CHSAPath
path ide :: Ident
ide) =
CHSAPath -> ShowS
showCHSAPath CHSAPath
path
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "."
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 = ".chi"
versionPrefix :: String
versionPrefix :: String
versionPrefix = "C->Haskell Interface Version "
loadAllCHI :: CHSModule -> CST s CHSModule
loadAllCHI :: CHSModule -> CST s CHSModule
loadAllCHI (CHSModule frags :: [CHSFrag]
frags) = do
let checkFrag :: CHSFrag -> PreCST SwitchBoard s CHSFrag
checkFrag (CHSHook (CHSImport qual :: Bool
qual name :: Ident
name fName :: String
fName pos :: 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 h :: 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 fname :: 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 -> 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]
++" 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 versline :: String
versline:chi :: [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
(major :: String
major, minor :: String
minor) <- case String -> Maybe (String, String)
majorMinor String
versline' of
Nothing -> String -> CST s (String, String)
forall s a. String -> CST s a
errorCHICorrupt String
fname
Just majMin :: (String, String)
majMin -> (String, String) -> CST s (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String, String)
majMin
(version :: String
version, _, _) <- PreCST SwitchBoard s (String, String, String)
forall e s. PreCST e s (String, String, String)
getId
let Just (myMajor :: String
myMajor, myMinor :: 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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
minor) (String
myMajor String -> ShowS
forall a. [a] -> [a] -> [a]
++ "." 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 fname :: String
fname = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
("Attempting to read file `"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ "'...\n")
traceInfoVersion :: CST s ()
traceInfoVersion = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
("...checking version `"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ "'...\n")
traceInfoOK :: CST s ()
traceInfoOK = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
("...successfully loaded `"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ "'.\n")
findFirst :: [String] -> PreCST e s String -> PreCST e s String
findFirst [] err :: PreCST e s String
err = PreCST e s String
err
findFirst (p :: String
p:aths :: [String]
aths) err :: 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 fname :: String
fname contents :: String
contents =
do
(version :: String
version, _, _) <- 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]
++ "\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
contents
majorMinor :: String -> Maybe (String, String)
majorMinor :: String -> Maybe (String, String)
majorMinor vers :: String
vers = let (major :: String
major, rest :: 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
== '.') String
vers
(minor :: String
minor, _ ) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.') (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 = "syntax"
ifError :: CST s a -> CST s a -> CST s a
ifError :: CST s a -> CST s a -> CST s a
ifError action :: CST s a
action handler :: 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 "syntax error"
parseCHSModule :: Position -> String -> CST s CHSModule
parseCHSModule :: Position -> String -> CST s CHSModule
parseCHSModule pos :: Position
pos cs :: 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 toks :: [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 pos :: Position
pos s :: String
s:toks :: [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 pos :: Position
pos c :: Char
c:toks :: [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 pos :: Position
pos s :: String
s:toks :: [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 pos :: Position
pos :toks :: [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 pos :: Position
pos s :: String
s:toks :: [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 pos :: Position
pos :toks :: [CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseImport Position
pos [CHSToken]
toks
parseFrags0 (CHSTokContext pos :: Position
pos :toks :: [CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseContext Position
pos [CHSToken]
toks
parseFrags0 (CHSTokType pos :: Position
pos :toks :: [CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseType Position
pos [CHSToken]
toks
parseFrags0 (CHSTokSizeof pos :: Position
pos :toks :: [CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseSizeof Position
pos [CHSToken]
toks
parseFrags0 (CHSTokEnum pos :: Position
pos :toks :: [CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseEnum Position
pos [CHSToken]
toks
parseFrags0 (CHSTokCall pos :: Position
pos :toks :: [CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseCall Position
pos [CHSToken]
toks
parseFrags0 (CHSTokFun pos :: Position
pos :toks :: [CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseFun Position
pos [CHSToken]
toks
parseFrags0 (CHSTokGet pos :: Position
pos :toks :: [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 pos :: Position
pos :toks :: [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 pos :: Position
pos :toks :: [CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseClass Position
pos [CHSToken]
toks
parseFrags0 (CHSTokPointer pos :: Position
pos :toks :: [CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parsePointer Position
pos [CHSToken]
toks
parseFrags0 (CHSTokPragma pos :: Position
pos :toks :: [CHSToken]
toks) = Position -> [CHSToken] -> CST s [CHSFrag]
forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parsePragma Position
pos [CHSToken]
toks
parseFrags0 toks :: [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 _ _:_ ) = [CHSToken] -> PreCST SwitchBoard s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
contFrags toks :: [CHSToken]
toks@(CHSTokCtrl _ _:_ ) = [CHSToken] -> PreCST SwitchBoard s [CHSFrag]
forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
contFrags (_ :toks :: [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 pos :: Position
pos s :: String
s toks :: [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 pos :: Position
pos c :: Char
c:toks :: [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 pos :: Position
pos s :: String
s:toks :: [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 toks :: [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 pos :: Position
pos toks :: [CHSToken]
toks = do
(qual :: Bool
qual, modid :: Ident
modid, toks' :: [CHSToken]
toks') <-
case [CHSToken]
toks of
CHSTokIdent _ ide :: Ident
ide :toks :: [CHSToken]
toks ->
let (ide' :: Ident
ide', toks' :: [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 _: CHSTokIdent _ ide :: Ident
ide:toks :: [CHSToken]
toks ->
let (ide' :: Ident
ide', toks' :: [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] -> 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 ide :: Ident
ide (CHSTokDot _ : CHSTokIdent _ ide' :: Ident
ide' : toks :: [CHSToken]
toks) =
let catIdent :: Ident -> Ident -> Ident
catIdent ide :: Ident
ide 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 -> 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 ide :: Ident
ide toks :: [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 '.' = '/'
dotToSlash c :: Char
c = Char
c
parseContext :: Position -> [CHSToken] -> CST s [CHSFrag]
parseContext :: Position -> [CHSToken] -> CST s [CHSFrag]
parseContext pos :: Position
pos toks :: [CHSToken]
toks = do
(olib :: Maybe String
olib , toks :: [CHSToken]
toks ) <- [CHSToken] -> CST s (Maybe String, [CHSToken])
forall s. [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptLib [CHSToken]
toks
(opref :: Maybe String
opref , toks :: [CHSToken]
toks) <- Bool -> [CHSToken] -> CST s (Maybe String, [CHSToken])
forall s. Bool -> [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptPrefix Bool
False [CHSToken]
toks
(olock :: Maybe String
olock , toks :: [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 pos :: Position
pos (CHSTokIdent _ ide :: Ident
ide:toks :: [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 _ toks :: [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 pos :: Position
pos (CHSTokIdent _ ide :: Ident
ide:toks :: [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 _ toks :: [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 pos :: Position
pos (CHSTokIdent _ ide :: Ident
ide:toks :: [CHSToken]
toks) =
do
(oalias :: Maybe Ident
oalias, toks' :: [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
(trans :: CHSTrans
trans , toks'' :: [CHSToken]
toks'') <- [CHSToken] -> CST s (CHSTrans, [CHSToken])
forall s. [CHSToken] -> CST s (CHSTrans, [CHSToken])
parseTrans [CHSToken]
toks'
(oprefix :: Maybe String
oprefix, toks''' :: [CHSToken]
toks''') <- Bool -> [CHSToken] -> CST s (Maybe String, [CHSToken])
forall s. Bool -> [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptPrefix Bool
True [CHSToken]
toks''
(derive :: [Ident]
derive, toks'''' :: [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 Nothing = Maybe Ident
forall a. Maybe a
Nothing
norm (Just ide' :: 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 _ toks :: [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 pos :: Position
pos toks :: [CHSToken]
toks =
do
(isPure :: Bool
isPure , toks :: [CHSToken]
toks ) <- [CHSToken] -> CST s (Bool, [CHSToken])
forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsPure [CHSToken]
toks
(isUnsafe :: Bool
isUnsafe, toks :: [CHSToken]
toks ) <- [CHSToken] -> CST s (Bool, [CHSToken])
forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsUnsafe [CHSToken]
toks
(isNolock :: Bool
isNolock, toks :: [CHSToken]
toks ) <- [CHSToken] -> CST s (Bool, [CHSToken])
forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsNolock [CHSToken]
toks
(ide :: Ident
ide , toks :: [CHSToken]
toks ) <- [CHSToken] -> CST s (Ident, [CHSToken])
forall s. [CHSToken] -> CST s (Ident, [CHSToken])
parseIdent [CHSToken]
toks
(oalias :: Maybe Ident
oalias , toks :: [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 pos :: Position
pos toks :: [CHSToken]
toks =
do
(isPure :: Bool
isPure , toks' :: [CHSToken]
toks' ) <- [CHSToken] -> CST s (Bool, [CHSToken])
forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsPure [CHSToken]
toks
(isUnsafe :: Bool
isUnsafe, toks'2 :: [CHSToken]
toks'2) <- [CHSToken] -> CST s (Bool, [CHSToken])
forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsUnsafe [CHSToken]
toks'
(isNolock :: Bool
isNolock, toks'3 :: [CHSToken]
toks'3) <- [CHSToken] -> CST s (Bool, [CHSToken])
forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsNolock [CHSToken]
toks'2
(ide :: Ident
ide , toks'4 :: [CHSToken]
toks'4) <- [CHSToken] -> CST s (Ident, [CHSToken])
forall s. [CHSToken] -> CST s (Ident, [CHSToken])
parseIdent [CHSToken]
toks'3
(oalias :: Maybe Ident
oalias , toks'5 :: [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
(octxt :: Maybe String
octxt , toks'6 :: [CHSToken]
toks'6) <- [CHSToken] -> PreCST SwitchBoard s (Maybe String, [CHSToken])
forall (m :: * -> *).
Monad m =>
[CHSToken] -> m (Maybe String, [CHSToken])
parseOptContext [CHSToken]
toks'5
(parms :: [CHSParm]
parms , toks'7 :: [CHSToken]
toks'7) <- [CHSToken] -> PreCST SwitchBoard s ([CHSParm], [CHSToken])
forall s.
[CHSToken] -> PreCST SwitchBoard s ([CHSParm], [CHSToken])
parseParms [CHSToken]
toks'6
(parm :: CHSParm
parm , toks'8 :: [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 _ ctxt :: String
ctxt:CHSTokDArrow _:toks :: [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 toks :: [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 _:CHSTokRBrace _:CHSTokArrow _:toks :: [CHSToken]
toks) =
([CHSParm], [CHSToken])
-> PreCST SwitchBoard s ([CHSParm], [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [CHSToken]
toks)
parseParms (CHSTokLBrace _ :toks :: [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 toks :: [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 _:CHSTokArrow _:toks :: [CHSToken]
toks) = ([CHSParm], [CHSToken])
-> PreCST SwitchBoard s ([CHSParm], [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [CHSToken]
toks)
parseParms' (CHSTokComma _ :toks :: [CHSToken]
toks) = do
(parm :: CHSParm
parm , toks' :: [CHSToken]
toks' ) <- [CHSToken] -> CST s (CHSParm, [CHSToken])
forall s. [CHSToken] -> CST s (CHSParm, [CHSToken])
parseParm [CHSToken]
toks
(parms :: [CHSParm]
parms, toks'' :: [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 _ :toks :: [CHSToken]
toks) = [CHSToken] -> PreCST SwitchBoard s ([CHSParm], [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseParms' toks :: [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 _:toks :: [CHSToken]
toks) = (Bool, [CHSToken]) -> CST s (Bool, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True , [CHSToken]
toks)
parseIsPure (CHSTokFun _:toks :: [CHSToken]
toks) = (Bool, [CHSToken]) -> CST s (Bool, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True , [CHSToken]
toks)
parseIsPure toks :: [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 _:toks :: [CHSToken]
toks) = (Bool, [CHSToken]) -> CST s (Bool, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True , [CHSToken]
toks)
parseIsUnsafe toks :: [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 _:toks :: [CHSToken]
toks) = (Bool, [CHSToken]) -> CST s (Bool, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True , [CHSToken]
toks)
parseIsNolock toks :: [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 ide :: Ident
ide Nothing = Maybe Ident
forall a. Maybe a
Nothing
norm ide :: Ident
ide (Just ide' :: 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 toks :: [CHSToken]
toks =
do
(oimMarsh :: Maybe (Ident, CHSArg)
oimMarsh, toks' :: [CHSToken]
toks' ) <- [CHSToken] -> CST s (Maybe (Ident, CHSArg), [CHSToken])
forall s. [CHSToken] -> CST s (Maybe (Ident, CHSArg), [CHSToken])
parseOptMarsh [CHSToken]
toks
(hsTyStr :: String
hsTyStr, twoCVals :: Bool
twoCVals, pos :: Position
pos, toks'2 :: [CHSToken]
toks'2) <-
case [CHSToken]
toks' of
(CHSTokHSVerb pos :: Position
pos hsTyStr :: String
hsTyStr:CHSTokAmp _:toks'2 :: [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 pos :: Position
pos hsTyStr :: String
hsTyStr :toks'2 :: [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)
toks :: [CHSToken]
toks -> [CHSToken]
-> PreCST SwitchBoard s (String, Bool, Position, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
(oomMarsh :: Maybe (Ident, CHSArg)
oomMarsh, toks'3 :: [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 _ ide :: Ident
ide:CHSTokStar _ :toks :: [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 _ ide :: Ident
ide:CHSTokMinus _:toks :: [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 _ ide :: Ident
ide :toks :: [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 toks :: [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 pos :: Position
pos access :: CHSAccess
access toks :: [CHSToken]
toks =
do
(path :: CHSAPath
path, toks' :: [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 pos :: Position
pos toks :: [CHSToken]
toks =
do
(isStar :: Bool
isStar, ide :: Ident
ide, toks' :: [CHSToken]
toks') <-
case [CHSToken]
toks of
CHSTokStar _:CHSTokIdent _ ide :: Ident
ide:toks' :: [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 _ ide :: Ident
ide :toks' :: [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] -> PreCST SwitchBoard s (Bool, Ident, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
(oalias :: Maybe Ident
oalias , toks'2 :: [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'
(ptrType :: CHSPtrType
ptrType, toks'3 :: [CHSToken]
toks'3) <- [CHSToken] -> CST s (CHSPtrType, [CHSToken])
forall s. [CHSToken] -> CST s (CHSPtrType, [CHSToken])
parsePtrType [CHSToken]
toks'2
let
(isNewtype :: Bool
isNewtype, oRefType :: Maybe Ident
oRefType, toks'4 :: [CHSToken]
toks'4) =
case [CHSToken]
toks'3 of
CHSTokNewtype _ :toks' :: [CHSToken]
toks' -> (Bool
True , Maybe Ident
forall a. Maybe a
Nothing , [CHSToken]
toks' )
CHSTokArrow _:CHSTokIdent _ ide :: Ident
ide:toks' :: [CHSToken]
toks' -> (Bool
False, Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
ide, [CHSToken]
toks' )
_ -> (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 _:toks :: [CHSToken]
toks) = (CHSPtrType, [CHSToken]) -> CST s (CHSPtrType, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (CHSPtrType
CHSForeignPtr, [CHSToken]
toks)
parsePtrType (CHSTokStable _ :toks :: [CHSToken]
toks) = (CHSPtrType, [CHSToken]) -> CST s (CHSPtrType, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (CHSPtrType
CHSStablePtr, [CHSToken]
toks)
parsePtrType toks :: [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 ide :: a
ide Nothing = Maybe a
forall a. Maybe a
Nothing
norm ide :: a
ide (Just ide' :: 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 pos :: Position
pos toks :: [CHSToken]
toks = do
let
parseExts :: [String]
-> [CHSToken] -> PreCST SwitchBoard s ([String], [CHSToken])
parseExts exts :: [String]
exts (CHSTokIdent _ ide :: Ident
ide:CHSTokComma _:toks :: [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 exts :: [String]
exts (CHSTokIdent _ ide :: Ident
ide:CHSTokPragEnd _:toks :: [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 exts :: [String]
exts toks :: [CHSToken]
toks = [CHSToken] -> PreCST SwitchBoard s ([String], [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
(exts :: [String]
exts, toks :: [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 pos :: Position
pos (CHSTokIdent _ sclassIde :: Ident
sclassIde:
CHSTokDArrow _ :
CHSTokIdent _ classIde :: Ident
classIde :
CHSTokIdent _ typeIde :: Ident
typeIde :
toks :: [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 pos :: Position
pos (CHSTokIdent _ classIde :: Ident
classIde :
CHSTokIdent _ typeIde :: Ident
typeIde :
toks :: [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 _ toks :: [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 _ :
CHSTokEqual _ :
CHSTokString _ str :: String
str:
toks :: [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 _:toks :: [CHSToken]
toks ) = [CHSToken] -> CST s (Maybe String, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseOptLib toks :: [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 _ :
CHSTokEqual _ :
CHSTokString _ str :: String
str:
toks :: [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 _:toks :: [CHSToken]
toks ) = [CHSToken] -> CST s (Maybe String, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseOptLock toks :: [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 False (CHSTokPrefix _ :
CHSTokEqual _ :
CHSTokString _ str :: String
str:
toks :: [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 True (CHSTokWith _ :
CHSTokPrefix _ :
CHSTokEqual _ :
CHSTokString _ str :: String
str:
toks :: [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 _ (CHSTokWith _:toks :: [CHSToken]
toks) = [CHSToken] -> CST s (Maybe String, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseOptPrefix _ (CHSTokPrefix _:toks :: [CHSToken]
toks) = [CHSToken] -> CST s (Maybe String, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseOptPrefix _ toks :: [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 _ _ (CHSTokAs _:CHSTokIdent _ ide :: Ident
ide:toks :: [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 ide :: Ident
ide upper :: Bool
upper (CHSTokAs _:CHSTokHat pos :: Position
pos :toks :: [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 _ _ (CHSTokAs _ :toks :: [CHSToken]
toks) = [CHSToken] -> CST s (Maybe Ident, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseOptAs _ _ toks :: [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 ide :: Ident
ide upper :: Bool
upper pos :: 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 s :: String
s = let (l :: String
l, s' :: 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
== '_') String
s
in
String
l String -> [String] -> [String]
forall a. a -> [a] -> [a]
: case String
s' of
[] -> []
(_:s'' :: String
s'') -> String -> [String]
parts String
s''
adjustCase :: ShowS
adjustCase (c :: Char
c:cs :: 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 "" = ""
adjustHead (c :: Char
c:cs :: 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 pos :: Position
pos:toks :: [CHSToken]
toks) =
do
(path :: CHSAPath
path, toks' :: [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 _ ide :: Ident
ide:toks :: [CHSToken]
toks) =
do
(pathWithHole :: CHSAPath -> CHSAPath
pathWithHole, toks' :: [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 toks :: [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 _:CHSTokIdent _ ide :: Ident
ide:toks :: [CHSToken]
toks) =
do
(pathWithHole :: CHSAPath -> CHSAPath
pathWithHole, toks' :: [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
. (\hole :: CHSAPath
hole -> CHSAPath -> Ident -> CHSAPath
CHSRef CHSAPath
hole Ident
ide), [CHSToken]
toks')
parsePath' (CHSTokDot _:toks :: [CHSToken]
toks) =
[CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parsePath' (CHSTokArrow pos :: Position
pos:CHSTokIdent _ ide :: Ident
ide:toks :: [CHSToken]
toks) =
do
(pathWithHole :: CHSAPath -> CHSAPath
pathWithHole, toks' :: [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
. (\hole :: CHSAPath
hole -> CHSAPath -> Ident -> CHSAPath
CHSRef (CHSAPath -> Position -> CHSAPath
CHSDeref CHSAPath
hole Position
pos) Ident
ide), [CHSToken]
toks')
parsePath' (CHSTokArrow _:toks :: [CHSToken]
toks) =
[CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parsePath' toks :: [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 _:toks :: [CHSToken]
toks) =
do
(_2Case :: Bool
_2Case, toks' :: [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 _:toks'' :: [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'')
_ ->
do
(transs :: [(Ident, Ident)]
transs, toks'' :: [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 _:toks :: [CHSToken]
toks) = (Bool, [CHSToken]) -> m (Bool, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, [CHSToken]
toks)
parse_2Case toks :: [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 _:toks :: [CHSToken]
toks) = ([(Ident, Ident)], [CHSToken])
-> PreCST SwitchBoard s ([(Ident, Ident)], [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [CHSToken]
toks)
parseTranss (CHSTokComma _:toks :: [CHSToken]
toks) = do
(assoc :: (Ident, Ident)
assoc, toks' :: [CHSToken]
toks' ) <- [CHSToken] -> PreCST SwitchBoard s ((Ident, Ident), [CHSToken])
forall s.
[CHSToken] -> PreCST SwitchBoard s ((Ident, Ident), [CHSToken])
parseAssoc [CHSToken]
toks
(trans :: [(Ident, Ident)]
trans, toks'' :: [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 toks :: [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 _ ide1 :: Ident
ide1:CHSTokAs _:CHSTokIdent _ ide2 :: Ident
ide2:toks :: [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 _ ide1 :: Ident
ide1:CHSTokAs _:toks :: [CHSToken]
toks ) =
[CHSToken] -> PreCST SwitchBoard s ((Ident, Ident), [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseAssoc (CHSTokIdent _ ide1 :: Ident
ide1:toks :: [CHSToken]
toks ) =
[CHSToken] -> PreCST SwitchBoard s ((Ident, Ident), [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseAssoc toks :: [CHSToken]
toks =
[CHSToken] -> PreCST SwitchBoard s ((Ident, Ident), [CHSToken])
forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseTrans toks :: [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 _ :CHSTokLParen _:CHSTokRParen _:toks :: [CHSToken]
toks) =
([Ident], [CHSToken]) -> CST s ([Ident], [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [CHSToken]
toks)
parseDerive (CHSTokDerive _ :CHSTokLParen _:toks :: [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 _:CHSTokIdent _ ide :: Ident
ide:toks :: [CHSToken]
toks) =
do
(ids :: [Ident]
ids, tok' :: [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 _ :toks :: [CHSToken]
toks) =
([Ident], [CHSToken]) -> CST s ([Ident], [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [CHSToken]
toks)
parseDerive toks :: [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 _ ide :: Ident
ide:toks :: [CHSToken]
toks) = (Ident, [CHSToken]) -> CST s (Ident, [CHSToken])
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
ide, [CHSToken]
toks)
parseIdent toks :: [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 _:toks :: [CHSToken]
toks) = [CHSToken] -> CST s [CHSToken]
forall (m :: * -> *) a. Monad m => a -> m a
return [CHSToken]
toks
parseEndHook toks :: [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 (tok :: CHSToken
tok:_) = 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 tok :: 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)
["Syntax error!",
"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]
++ "' 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
["Premature end of file!",
"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 ide :: String
ide = do
Position -> [String] -> PreCST SwitchBoard s ()
forall e s. Position -> [String] -> PreCST e s ()
raiseError Position
nopos
["Unknown .chi file!",
"Cannot find the .chi file for `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ide String -> ShowS
forall a. [a] -> [a] -> [a]
++ "'."]
CST s a
forall s a. CST s a
raiseSyntaxError
errorCHICorrupt :: String -> CST s a
errorCHICorrupt :: String -> CST s a
errorCHICorrupt ide :: String
ide = do
Position -> [String] -> PreCST SwitchBoard s ()
forall e s. Position -> [String] -> PreCST e s ()
raiseError Position
nopos
["Corrupt .chi file!",
"The file `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ide String -> ShowS
forall a. [a] -> [a] -> [a]
++ ".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 ide :: String
ide chiVersion :: String
chiVersion myVersion :: String
myVersion = do
Position -> [String] -> PreCST SwitchBoard s ()
forall e s. Position -> [String] -> PreCST e s ()
raiseError Position
nopos
["Wrong version of .chi file!",
"The file `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ide String -> ShowS
forall a. [a] -> [a] -> [a]
++ ".chi' is version "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
chiVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", but mine is " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
myVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++ "."]
CST s a
forall s a. CST s a
raiseSyntaxError