{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
module HSE.All(
module X,
CppFlags(..), ParseFlags(..), defaultParseFlags,
parseFlagsAddFixities, parseFlagsSetLanguage,
parseModuleEx, ParseError(..),
freeVars, vars, varss, pvars
) where
import Language.Haskell.Exts.Util hiding (freeVars, Vars(..))
import qualified Language.Haskell.Exts.Util as X
import HSE.Util as X
import HSE.Reduce as X
import HSE.Type as X
import HSE.Match as X
import HSE.Scope as X
import Util
import Data.Char
import Data.List.Extra
import Data.Maybe
import Timing
import Language.Preprocessor.Cpphs
import Data.Set (Set)
import qualified Data.Map as Map
import qualified Data.Set as Set
import System.IO.Extra
import Data.Functor
import Prelude
vars :: FreeVars a => a -> [String]
freeVars :: FreeVars a => a -> Set String
varss, pvars :: AllVars a => a -> [String]
vars = Set.toList . Set.map prettyPrint . X.freeVars
varss = Set.toList . Set.map prettyPrint . X.free . X.allVars
pvars = Set.toList . Set.map prettyPrint . X.bound . X.allVars
freeVars = Set.map prettyPrint . X.freeVars
data CppFlags
= NoCpp
| CppSimple
| Cpphs CpphsOptions
data ParseFlags = ParseFlags
{cppFlags :: CppFlags
,hseFlags :: ParseMode
}
lensFixities :: [Fixity]
lensFixities = concat
[infixr_ 4 ["%%@~","<%@~","%%~","<+~","<*~","<-~","<//~","<^~","<^^~","<**~"]
,infix_ 4 ["%%@=","<%@=","%%=","<+=","<*=","<-=","<//=","<^=","<^^=","<**="]
,infixr_ 2 ["<<~"]
,infixr_ 9 ["#."]
,infixl_ 8 [".#"]
,infixr_ 8 ["^!","^@!"]
,infixl_ 1 ["&","<&>","??"]
,infixl_ 8 ["^.","^@."]
,infixr_ 9 ["<.>","<.",".>"]
,infixr_ 4 ["%@~",".~","+~","*~","-~","//~","^~","^^~","**~","&&~","<>~","||~","%~"]
,infix_ 4 ["%@=",".=","+=","*=","-=","//=","^=","^^=","**=","&&=","<>=","||=","%="]
,infixr_ 2 ["<~"]
,infixr_ 2 ["`zoom`","`magnify`"]
,infixl_ 8 ["^..","^?","^?!","^@..","^@?","^@?!"]
,infixl_ 8 ["^#"]
,infixr_ 4 ["<#~","#~","#%~","<#%~","#%%~"]
,infix_ 4 ["<#=","#=","#%=","<#%=","#%%="]
,infixl_ 9 [":>"]
,infixr_ 4 ["</>~","<</>~","<.>~","<<.>~"]
,infix_ 4 ["</>=","<</>=","<.>=","<<.>="]
,infixr_ 4 [".|.~",".&.~","<.|.~","<.&.~"]
,infix_ 4 [".|.=",".&.=","<.|.=","<.&.="]
]
otherFixities :: [Fixity]
otherFixities = concat
[infix_ 1 ["`shouldBe`","`shouldSatisfy`","`shouldStartWith`","`shouldEndWith`","`shouldContain`","`shouldMatchList`"
,"`shouldReturn`","`shouldNotBe`","`shouldNotSatisfy`","`shouldNotContain`","`shouldNotReturn`","`shouldThrow`"]
,infixr_ 0 ["==>"]
,infix_ 4 ["==="]
,infix_ 4 ["==."]
,infixr_ 5 ["\\/"]
,infixr_ 6 ["/\\"]
]
baseNotYetInHSE :: [Fixity]
baseNotYetInHSE = concat
[infixr_ 9 ["`Compose`"]
,infixr_ 6 ["<>"]
,infixr_ 5 ["<|"]
,infixl_ 4 ["<$!>","<$","$>"]
,infix_ 4 [":~:", ":~~:"]
]
customFixities :: [Fixity]
customFixities =
infixl_ 1 ["`on`"]
defaultParseFlags :: ParseFlags
defaultParseFlags = ParseFlags NoCpp defaultParseMode
{fixities = Just $ customFixities ++ baseFixities ++ baseNotYetInHSE ++ lensFixities ++ otherFixities
,ignoreLinePragmas = False
,ignoreFunctionArity = True
,extensions = defaultExtensions}
parseFlagsNoLocations :: ParseFlags -> ParseFlags
parseFlagsNoLocations x = x{cppFlags = case cppFlags x of Cpphs y -> Cpphs $ f y; y -> y}
where f x = x{boolopts = (boolopts x){locations=False}}
parseFlagsAddFixities :: [Fixity] -> ParseFlags -> ParseFlags
parseFlagsAddFixities fx x = x{hseFlags=hse{fixities = Just $ fx ++ fromMaybe [] (fixities hse)}}
where hse = hseFlags x
parseFlagsSetLanguage :: (Language, [Extension]) -> ParseFlags -> ParseFlags
parseFlagsSetLanguage (l, es) x = x{hseFlags=(hseFlags x){baseLanguage = l, extensions = es}}
runCpp :: CppFlags -> FilePath -> String -> IO String
runCpp NoCpp _ x = return x
runCpp CppSimple _ x = return $ unlines [if "#" `isPrefixOf` trimStart x then "" else x | x <- lines x]
runCpp (Cpphs o) file x = dropLine <$> runCpphs o file x
where
dropLine (line1 -> (a,b)) | "{-# LINE " `isPrefixOf` a = b
dropLine x = x
data ParseError = ParseError
{parseErrorLocation :: SrcLoc
,parseErrorMessage :: String
,parseErrorContents :: String
}
parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError (Module SrcSpanInfo, [Comment]))
parseModuleEx flags file str = timedIO "Parse" file $ do
str <- case str of
Just x -> return x
Nothing | file == "-" -> getContents
| otherwise -> readFileUTF8' file
str <- return $ fromMaybe str $ stripPrefix "\65279" str
ppstr <- runCpp (cppFlags flags) file str
case parseFileContentsWithComments (mode flags) ppstr of
ParseOk (x, cs) -> return $ Right (applyFixity fixity x, cs)
ParseFailed sl msg -> do
flags <- return $ parseFlagsNoLocations flags
ppstr2 <- runCpp (cppFlags flags) file str
let pe = case parseFileContentsWithMode (mode flags) ppstr2 of
ParseFailed sl2 _ -> context (srcLine sl2) ppstr2
_ -> context (srcLine sl) ppstr
return $ Left $ ParseError sl msg pe
where
fixity = fromMaybe [] $ fixities $ hseFlags flags
mode flags = (hseFlags flags)
{parseFilename = file
,fixities = Nothing
}
context :: Int -> String -> String
context lineNo src =
unlines $ dropWhileEnd (all isSpace) $ dropWhile (all isSpace) $
zipWith (++) ticks $ take 5 $ drop (lineNo - 3) $ lines src ++ ["","","","",""]
where ticks = [" "," ","> "," "," "]
applyFixity :: [Fixity] -> Module_ -> Module_
applyFixity base modu = descendBi f modu
where
f x = fromMaybe (cheapFixities fixs x) $ applyFixities fixs x :: Decl_
fixs = concatMap getFixity (moduleDecls modu) ++ base
cheapFixities :: [Fixity] -> Decl_ -> Decl_
cheapFixities fixs = descendBi (transform f)
where
ask = askFixity fixs
f o@(InfixApp s1 (InfixApp s2 x op1 y) op2 z)
| p1 == p2 && (a1 /= a2 || isAssocNone a1) = o
| p1 > p2 || p1 == p2 && (isAssocLeft a1 || isAssocNone a2) = o
| otherwise = InfixApp s1 x op1 (f $ InfixApp s1 y op2 z)
where
(a1,p1) = ask op1
(a2,p2) = ask op2
f x = x
askFixity :: [Fixity] -> QOp S -> (Assoc (), Int)
askFixity xs = \k -> Map.findWithDefault (AssocLeft (), 9) (fromNamed k) mp
where
mp = Map.fromList [(s,(a,p)) | Fixity a p x <- xs, let s = fromNamed $ fmap (const an) x, s /= ""]