module UHC.Light.Compiler.Scanner.Common
( module UHC.Light.Compiler.Scanner.Common
, module UHC.Light.Compiler.Scanner.Scanner )
where
import System.IO
import UU.Parsing
import UU.Parsing.Offside
import UU.Scanner.Position
import UU.Scanner.GenToken
import UU.Scanner.GenTokenParser
import UHC.Util.ScanUtils ()
import UHC.Light.Compiler.Base.HsName.Builtin
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Opts.Base
import qualified Data.Set as Set
import UHC.Util.ScanUtils
import UHC.Light.Compiler.Scanner.Scanner
import UHC.Util.ParseUtils
import UHC.Light.Compiler.Base.Target
import Data.Ratio
ehScanOpts :: EHCOpts -> ScanOpts
ehScanOpts opts
= defaultScanOpts
{ scoKeywordsTxt =
Set.fromList $
tokKeywStrsEH1
++ offsideTrigs
++ tokKeywStrsEH4
++ tokKeywStrsEH5
++ tokKeywStrsEH6
++ tokKeywStrsEH8
++ tokKeywStrsEH9
++ tokKeywStrsEH11
++ tokKeywStrsEH12
++ tokKeywStrsEH90
++ tokKeywStrsEH91
++ (if ehcOptFusion opts then tokKeywStrsEH93 else [])
, scoKeywordsOps =
Set.fromList $
tokOpStrsEH1
++ tokOpStrsEH2
++ tokOpStrsEH3
++ tokOpStrsEH4
++ tokOpStrsEH5
++ tokOpStrsEH6
++ (if ehcOptExtensibleRecords opts then tokOpStrsEH7 else [])
++ tokOpStrsEH9
++ tokOpStrsEH10
++ tokOpStrsEH11
, scoSpecChars = Set.fromList $
"();,[]{}`"
, scoOpChars = Set.fromList $
"!#$%&*+/<=>?@\\^|-:.~"
, scoSpecPairs = Set.fromList $
[ show hsnORow, show hsnCRow
, show hsnOSum, show hsnCSum
, show hsnOImpl, show hsnCImpl
]
, scoOffsideTrigs = offsideTrigs
, scoOffsideTrigsGE = offsideTrigsGE
, scoOffsideModule = "let"
, scoOffsideOpen = "{"
, scoOffsideClose = "}"
}
where offsideTrigs =
[ "let", "where"
, "of"
, "letstrict"
]
offsideTrigsGE =
[ "do"
]
hsScanOpts :: EHCOpts -> ScanOpts
hsScanOpts opts
= ehScanOpts'
{ scoKeywordsTxt =
scoKeywordsTxt ehScanOpts' `Set.union`
(Set.fromList $
offsideTrigs
++ tokKeywStrsHS1
++ tokKeywStrsHS4
++ tokKeywStrsHS5
++ tokKeywStrsHS6
++ tokKeywStrsHS8
++ tokKeywStrsHS9
++ tokKeywStrsHS11
++ tokKeywStrsHS12
++ tokKeywStrsHS90
++ (if ehcOptFusion opts then tokKeywStrsHS93 else [])
)
, scoPragmasTxt =
(Set.fromList $
tokPragmaStrsHS99
)
, scoKeywordsOps =
scoKeywordsOps ehScanOpts'
`Set.union`
(Set.fromList $
tokOpStrsHS1
++ tokOpStrsHS2
++ tokOpStrsHS3
++ tokOpStrsHS4
++ tokOpStrsHS5
++ tokOpStrsHS6
++ tokOpStrsHS7
++ tokOpStrsHS9
++ tokOpStrsHS10
++ tokOpStrsHS11
)
, scoOffsideTrigs =
scoOffsideTrigs ehScanOpts'
++ offsideTrigs
, scoOffsideTrigsGE =
scoOffsideTrigsGE ehScanOpts'
, scoOffsideModule = "module"
}
where offsideTrigs =
[ "where"
]
ehScanOpts' = ehScanOpts opts
coreScanOpts :: EHCOpts -> ScanOpts
coreScanOpts opts
= grinScanOpts
{ scoKeywordsTxt = (Set.fromList $
[ "let", "in", "case", "of", "rec", "foreign", "uniq"
, "Int", "Char", "String", "Tag", "Rec"
, "module", "default"
, "import", "export"
, "BINDPLAIN", "BINDFUNCTION0", "BINDFUNCTION1", "BINDAPPLY0"
, "VAL"
, "FAIL"
, "DICT", "DICTCLASS", "DICTINSTANCE", "DICTOVERLOADED", "TRACK"
, "Integer"
, "foreignexport"
])
`Set.union` scoKeywordsTxt tyScanOpts
`Set.union` scoKeywordsTxt hsScanOpts'
, scoKeywExtraChars = Set.fromList "."
, scoKeywordsOps = scoKeywordsOps grinScanOpts `Set.union` scoKeywordsOps hsScanOpts'
, scoDollarIdent = True
, scoOpChars = Set.fromList "<->:=+*"
, scoSpecChars = Set.fromList "!=();{}#\\|,`"
, scoSpecPairs = Set.fromList [] `Set.union` scoSpecPairs ehScanOpts'
}
where hsScanOpts' = hsScanOpts opts
ehScanOpts' = ehScanOpts opts
corerunScanOpts :: ScanOpts
corerunScanOpts
= defaultScanOpts
{ scoKeywordsTxt = Set.fromList $
[ "alloc", "module", "tail", "eval", "case", "of", "let", "in", "app", "ffi", "dbg", "tag"
, "g", "d", "l"
]
, scoKeywordsOps = Set.fromList [ "->", "\\" ]
, scoSpecChars = Set.fromList "();,."
, scoOpChars = Set.fromList "->\\"
, scoAllowFloat = False
}
tycoreScanOpts :: ScanOpts
tycoreScanOpts
= defaultScanOpts
{ scoKeywordsTxt = (Set.fromList $
[ "let", "in", "case", "of", "rec", "foreign", "uniq"
, "Int", "Char", "String", "Tag", "Rec"
, "module", "default"
, "BINDPLAIN", "BINDFUNCTION0", "BINDFUNCTION1", "BINDAPPLY0"
, "VAL"
, "DICT", "DICTCLASS", "DICTINSTANCE", "DICTOVERLOADED"
, "Integer"
, "foreignexport"
])
, scoKeywordsOps = Set.fromList [ "->", "=", ":", "::", "|", "\\" ]
, scoSpecChars = Set.fromList "();{},[]"
, scoOpChars = Set.fromList "|\\:=-<>"
, scoDollarIdent = True
}
grinScanOpts :: ScanOpts
grinScanOpts
= defaultScanOpts
{ scoKeywordsTxt = Set.fromList $
[ "eval", "apply"
, "call"
, "module", "update", "fetch", "store", "unit", "of", "rec", "case", "ffi", "fetchupdate"
, "throw", "try", "catch", "ctags", "applymap", "evalmap"
, "C", "F", "P", "A", "R", "H", "U", "W"
, "basicnode", "enumnode", "opaquenode", "ptrnode", "basicannot", "enumannot", "opaqueannot", "ptrannot"
, "annotfromtaggedptr", "annottotaggedptr", "annotdflt"
, "word"
, "DICTCLASS", "DICTINSTANCE", "DICTOVERLOADED", "SPECIALIZED"
, "_"
, "float", "double"
, "True", "False"
]
++ map show allFFIWays
, scoKeywordsOps = Set.fromList [ "<-", "->", "=", "+=", "-=", ":=", "-", "*" ]
, scoSpecChars = Set.fromList "();{}#/\\|,"
, scoOpChars = Set.fromList "<->:=+*"
, scoDollarIdent = True
}
tyScanOpts :: ScanOpts
tyScanOpts
= defaultScanOpts
{ scoKeywordsTxt = Set.fromList [ "uid" ]
}
hsnScanOpts :: ScanOpts
hsnScanOpts
= defaultScanOpts
{ scoKeywordsTxt = Set.fromList
[ "NEW"
, "ERR"
, "UNQ"
, "EVL"
, "FLD"
, "CLS"
, "DCT"
, "SDC"
, "RDC"
, "SUP"
, "DFL"
, "INL"
, "UND"
, "OFF"
, "CCN"
, "UPD"
, "FFI"
, "LBL"
, "ASP"
, "STR"
, "GEN"
, "FFE"
, "FFC"
]
, scoSpecChars = Set.fromList ".{},`"
, scoOpChars = Set.fromList "[]:" `Set.union` scoOpChars hsScanOpts'
, scoAllowQualified = False
}
where hsScanOpts' = hsScanOpts emptyEHCOpts
foreignEntScanOpts :: FFIWay -> ScanOpts
foreignEntScanOpts way
= o { scoKeywordsTxt = Set.fromList [ "dynamic", "wrapper", "h", "static", "new", "js" ]
, scoSpecChars = Set.fromList ",.&%[]()*{}"
, scoDollarIdent = False
, scoKeywExtraChars = Set.fromList wayKeywExtraChars
, scoAllowQualified = False
, scoStringDelims = scoStringDelims o ++ wayStringDelims
}
where o = defaultScanOpts
(wayKeywExtraChars,wayStringDelims)
= case way of
_ -> ("" , "" )
splitTokensOnModuleTrigger :: ScanOpts -> [Token] -> Maybe ([Token],[Token])
splitTokensOnModuleTrigger scanOpts ts
= case break ismod ts of
(ts1,ts2@[]) -> Nothing
tss -> Just tss
where ismod (Reserved s _) | s == scoOffsideModule scanOpts = True
ismod _ = False
offsideScanHandle :: ScanOpts -> FilePath -> Handle -> IO (OffsideInput [Token] Token (Maybe Token))
offsideScanHandle scanOpts fn fh
= do { tokens <- scanHandle scanOpts fn fh
; case splitTokensOnModuleTrigger scanOpts tokens of
Just (ts1,ts2) -> return $ scanLiftTokensToOffside ts1
$ scanOffsideWithTriggers moduleT oBrace cBrace triggers ts2
_ -> return $ scanOffsideWithTriggers moduleT oBrace cBrace triggers tokens
}
where moduleT = reserved (scoOffsideModule scanOpts) noPos
oBrace = reserved (scoOffsideOpen scanOpts) noPos
cBrace = reserved (scoOffsideClose scanOpts) noPos
triggers = [ (Trigger_IndentGT,reserved x noPos) | x <- scoOffsideTrigs scanOpts ]
++ [ (Trigger_IndentGE,reserved x noPos) | x <- scoOffsideTrigsGE scanOpts ]
floatDenot2NomDenom :: String -> (Integer,Integer)
floatDenot2NomDenom denot
= (numerator f,denominator f)
where (n,m,e) = getRational denot
f :: Rational
f = ((read n * md + mn) * en) % (ed * md)
en, ed, mn, md :: Integer
(en,ed) = case e of
Just (Just "-",e) -> (1,10 ^ read e)
Just (_,e) -> (10 ^ read e,1)
_ -> (1,1)
(mn,md) = case m of
Just m -> (read m,10 ^ length m)
_ -> (1,1)
intDenot2Integer :: Int -> String -> Integer
intDenot2Integer b s = getBaseNumber (toInteger b) s
pKeyTk, pKeyTk' :: IsParser p Token
=> String -> p Token
pKeyTk key = pCostReserved' 9 key
pKeyTk' key = pCostReserved' 8 key
pKeyw :: (IsParser p Token,Show k) => k -> p Token
pKeyw k = pKeyTk (show k)
pKeywHsNname :: (IsParser p Token,Show k) => k -> p HsName
pKeywHsNname k = tokMkQName <$> pKeyw k
pStringTk, pCharTk,
pInteger8Tk, pInteger10Tk, pInteger16Tk, pFractionTk,
pQVaridTk, pQConidTk,
pQVarsymTk, pQConsymTk,
pVaridTk , pConidTk ,
pVaridTk', pConidTk',
pTextnmTk, pTextlnTk, pIntegerTk, pVarsymTk, pConsymTk
:: IsParser p Token => p Token
pStringTk = pHsCostValToken' 7 TkString ""
pCharTk = pHsCostValToken' 7 TkChar "\NUL"
pInteger8Tk = pHsCostValToken' 7 TkInteger8 "0"
pInteger10Tk = pHsCostValToken' 7 TkInteger10 "0"
pInteger16Tk = pHsCostValToken' 7 TkInteger16 "0"
pFractionTk = pHsCostValToken' 7 TkFraction "0.0"
pVaridTk = pHsCostValToken' 7 TkVarid "<identifier>"
pVaridTk' = pHsCostValToken' 6 TkVarid "<identifier>"
pConidTk = pHsCostValToken' 7 TkConid "<Identifier>"
pConidTk' = pHsCostValToken' 6 TkConid "<Identifier>"
pConsymTk = pHsCostValToken' 7 TkConOp "<conoperator>"
pVarsymTk = pHsCostValToken' 7 TkOp "<operator>"
pTextnmTk = pHsCostValToken' 7 TkTextnm "<name>"
pTextlnTk = pHsCostValToken' 7 TkTextln "<line>"
pIntegerTk = pInteger10Tk
pQVaridTk = pHsCostValToken' 7 TkQVarid "<identifier>"
pQConidTk = pHsCostValToken' 7 TkQConid "<Identifier>"
pQConsymTk = pHsCostValToken' 7 TkQConOp "<conoperator>"
pQVarsymTk = pHsCostValToken' 7 TkQOp "<operator>"
pCONID, pCONID', pCONSYM, pVARID, pVARID', pVARSYM :: IsParser p Token => p Token
pCONID = pConidTk
pCONID' = pConidTk
pCONSYM = pConsymTk
pVARID = pVaridTk
pVARID' = pVaridTk'
pVARSYM = pVarsymTk
pQCONID, pQCONSYM, pQVARID, pQVARSYM :: IsParser p Token => p Token
pQCONID = pQConidTk
pQCONSYM = pQConsymTk
pQVARID = pQVaridTk
pQVARSYM = pQVarsymTk
tokGetVal :: Token -> String
tokGetVal x
= tokenVal x
pV :: (IsParser p Token) => p Token -> p String
pV p = tokGetVal <$> p
pHNm :: (IsParser p Token) => p Token -> p HsName
pHNm p = (hsnFromString . tokGetVal) <$> p
tokConcat :: Token -> Token -> Token
tokConcat t1 t2 = Reserved (tokenVal t1 ++ tokenVal t2) (position t1)
tokEmpty :: Token
tokEmpty = Reserved "" noPos
pMODULE ,
pWHERE ,
pSEMI ,
pDCOLON ,
pCOLON ,
pOBRACK ,
pCBRACK ,
pOCURLY ,
pCCURLY ,
pVOCURLY ,
pVCCURLY ,
pAT ,
pPERCENT ,
pDOT ,
pCOMMA ,
pOPAREN ,
pCPAREN ,
pINFIX ,
pINFIXL ,
pINFIXR ,
pMINUS ,
pSTAR ,
pBANG ,
pEQUAL ,
pRARROW ,
pBACKQUOTE ,
pLET ,
pLAM ,
pSLASH ,
pUNDERSCORE,
pIN
:: IsParser p Token => p Token
pMODULE = pKeyTk "module"
pWHERE = pKeyTk "where"
pSEMI = pKeyTk ";"
pCOLON = pKeyTk ":"
pDCOLON = pKeyTk "::"
pOBRACK = pKeyTk "["
pCBRACK = pKeyTk "]"
pOCURLY = pKeyTk "{"
pCCURLY = pKeyTk "}"
pVOCURLY = pKeyTk "{-layout"
pVCCURLY = pKeyTk "}-layout"
pAT = pKeyTk "@"
pPERCENT = pKeyTk "%"
pDOT = pKeyTk "."
pCOMMA = pKeyTk ","
pOPAREN = pKeyTk "("
pCPAREN = pKeyTk ")"
pINFIX = pKeyTk "infix"
pINFIXL = pKeyTk "infixl"
pINFIXR = pKeyTk "infixr"
pMINUS = pKeyTk "-"
pSTAR = pKeyTk "*"
pBANG = pKeyTk "!"
pEQUAL = pKeyTk "="
pRARROW = pKeyw hsnArrow
pBACKQUOTE = pKeyTk "`"
pLET = pKeyTk "let"
pLAM = pKeyTk "\\"
pSLASH = pKeyTk "/"
pUNDERSCORE = pKeyTk "_"
pIN = pKeyTk "in"
tokKeywStrsEH1 = [ "in", "let" ]
tokKeywStrsHS1 = [ "module", "where", "infix", "infixl", "infixr" ]
tokOpStrsEH1 = [ "=", "\\", show hsnArrow, "::", "@" ]
tokOpStrsHS1 = [ "-", "*", "!", "_", "%", "." ]
pTDOT ,
pQDOT
:: IsParser p Token => p Token
pTDOT = pKeyTk "..."
pQDOT = pKeyTk "...."
tokOpStrsEH2 = [ "...", "...." ]
tokOpStrsHS2 = [ ]
tokOpStrsEH3 = [ "%" ]
tokOpStrsHS3 = [ ]
pFORALL ,
pEXISTS ,
pTILDE
:: IsParser p Token => p Token
pFORALL = pKeyTk "forall"
pEXISTS = pKeyTk "exists"
pTILDE = pKeyTk (show hsnEqTilde)
tokKeywStrsEH4 = [ "forall", "exists" ]
tokKeywStrsHS4 = [ ]
tokOpStrsEH4 = [ ".", show hsnEqTilde ]
tokOpStrsHS4 = [ ]
pLARROW ,
pVBAR ,
pDATA ,
pNEWTYPE ,
pCASE ,
pOF ,
pIF ,
pTHEN ,
pELSE ,
pDOTDOT
:: IsParser p Token => p Token
pLARROW = pKeyTk "<-"
pVBAR = pKeyTk "|"
pDATA = pKeyTk "data"
pNEWTYPE = pKeyTk "newtype"
pCASE = pKeyTk "case"
pOF = pKeyTk "of"
pIF = pKeyTk "if"
pTHEN = pKeyTk "then"
pELSE = pKeyTk "else"
pDOTDOT = pKeyTk ".."
tokKeywStrsEH5 = [ "data", "case", "if", "then", "else", "of" ]
tokKeywStrsHS5 = [ "newtype" ]
tokOpStrsEH5 = [ "|" ]
tokOpStrsHS5 = [ "<-", "..", ":" ]
pFFORALL ,
pEEXISTS
:: IsParser p Token => p Token
pFFORALL = pKeyTk "Forall"
pEEXISTS = pKeyTk "Exists"
tokKeywStrsEH6 = [ ]
tokKeywStrsHS6 = [ ]
tokKeywStrsHI6 = [ "Forall", "Exists" ]
tokOpStrsEH6 = [ "*" ]
tokOpStrsHS6 = [ ]
pOROWREC ,
pCROWREC ,
pOROWROW ,
pCROWROW ,
pOROWSUM ,
pCROWSUM ,
pCOLEQUAL ,
pHASH
:: IsParser p Token => p Token
pOROWREC = pKeyTk (show hsnORec)
pCROWREC = pKeyTk (show hsnCRec)
pOROWROW = pKeyTk (show hsnORow)
pCROWROW = pKeyTk (show hsnCRow)
pOROWSUM = pKeyTk (show hsnOSum)
pCROWSUM = pKeyTk (show hsnCSum)
pCOLEQUAL = pKeyTk ":="
pHASH = pKeyTk "#"
tokOpStrsEH7 = [ ":=", "#" ]
tokOpStrsHS7 = [ ]
pLABEL ,
pLETSTRICT ,
pSAFE ,
pFOREIGN ,
pDEFAULT ,
pIMPORT ,
pEXPORT
:: IsParser p Token => p Token
pLABEL = pKeyTk "label"
pLETSTRICT = pKeyTk "letstrict"
pSAFE = pKeyTk "safe"
pFOREIGN = pKeyTk "foreign"
pDEFAULT = pKeyTk "default"
pIMPORT = pKeyTk "import"
pEXPORT = pKeyTk "export"
tokKeywStrsEH8
= [ "letstrict", "foreign", "import" ]
++ map show allFFIWays
tokKeywStrsHS8 = [ "default", "export", "label", "safe" ]
pFFIWay :: IsParser p Token => p (FFIWay,Token)
pFFIWay
= pAnyKey (\way -> (,) way <$> pKeyTk (show way)) allFFIWays
<?> "pFFIWay"
pDARROW ,
pLTCOLON ,
pOIMPL ,
pCIMPL ,
pCLASS ,
pINSTANCE ,
pDO
:: IsParser p Token => p Token
pDARROW = pKeyTk (show hsnPrArrow)
pLTCOLON = pKeyTk "<:"
pOIMPL = pKeyTk (show hsnOImpl)
pCIMPL = pKeyTk (show hsnCImpl)
pCLASS = pKeyTk "class"
pINSTANCE = pKeyTk "instance"
pDO = pKeyTk "do"
tokKeywStrsEH9 = [ "class", "instance" ]
tokKeywStrsHS9 = [ "do" ]
tokOpStrsEH9 = [ show hsnPrArrow, "<:" ]
tokOpStrsHS9 = [ ]
tokOpStrsEH10 = []
tokOpStrsHS10 = [ ]
pTYPE
:: IsParser p Token => p Token
pTYPE = pKeyTk "type"
tokKeywStrsEH11 = [ "type" ]
tokKeywStrsHS11 = [ ]
tokOpStrsEH11 = [ ]
tokOpStrsHS11 = [ ]
pQUALIFIED ,
pQUESTQUEST ,
pAS ,
pHIDING
:: IsParser p Token => p Token
pQUALIFIED = pKeyTk "qualified"
pAS = pKeyTk "as"
pHIDING = pKeyTk "hiding"
pQUESTQUEST = pKeyTk "??"
tokKeywStrsEH12 = [ ]
tokKeywStrsHS12 = [ "qualified", "as", "hiding" ]
pDERIVING
:: IsParser p Token => p Token
pDERIVING = pKeyTk "deriving"
tokKeywStrsEH91 = [ "deriving" ]
pUNSAFE ,
pTHREADSAFE ,
pDYNAMIC ,
pWRAPPER ,
pSTATIC ,
pH ,
pNEW ,
pJS ,
pAMPERSAND
:: IsParser p Token => p Token
pUNSAFE = pKeyTk "unsafe"
pTHREADSAFE = pKeyTk "threadsafe"
pDYNAMIC = pKeyTk "dynamic"
pWRAPPER = pKeyTk "wrapper"
pSTATIC = pKeyTk "static"
pH = pKeyTk "h"
pAMPERSAND = pKeyTk "&"
pNEW = pKeyTk "new"
pJS = pKeyTk "js"
tokKeywStrsEH90 = [ ]
tokKeywStrsHS90 = [ "unsafe", "threadsafe", "dynamic" ]
pFUSE ,
pCONVERT
:: IsParser p Token => p Token
pFUSE = pKeyTk "fuse"
pCONVERT = pKeyTk "convert"
tokKeywStrsEH93 = [ ]
tokKeywStrsHS93 = [ "fuse", "convert" ]
pLANGUAGE_prag ,
pOPTIONSUHC_prag ,
pDERIVABLE_prag ,
pEXCLUDEIFTARGET_prag,
pOPRAGMA ,
pCPRAGMA
:: IsParser p Token => p Token
pLANGUAGE_prag = pKeyTk "LANGUAGE"
pDERIVABLE_prag = pKeyTk "DERIVABLE"
pEXCLUDEIFTARGET_prag = pKeyTk "EXCLUDE_IF_TARGET"
pOPTIONSUHC_prag = pKeyTk "OPTIONS_UHC"
pOPRAGMA = pKeyTk "{-#"
pCPRAGMA = pKeyTk "#-}"
tokPragmaStrsHS99= [ "LANGUAGE", "DERIVABLE", "EXCLUDE_IF_TARGET", "OPTIONS_UHC" ]