<commit_before>%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%

This module converts Template Haskell syntax into HsSyn


\begin{code}
module Convert( convertToHsExpr, convertToHsDecls ) where

#include "HsVersions.h"

import Language.Haskell.THSyntax as Meta

import HsSyn as Hs
	(	HsExpr(..), HsLit(..), ArithSeqInfo(..), 
		HsStmtContext(..), TyClDecl(..),
		Match(..), GRHSs(..), GRHS(..), HsPred(..),
		HsDecl(..), TyClDecl(..), InstDecl(..), ConDecl(..),
		Stmt(..), HsBinds(..), MonoBinds(..), Sig(..),
		Pat(..), HsConDetails(..), HsOverLit, BangType(..),
		placeHolderType, HsType(..), HsTupCon(..),
		HsTyVarBndr(..), HsContext,
		mkSimpleMatch
	) 

import RdrName	( RdrName, mkRdrUnqual, mkRdrQual, mkOrig )
import Module   ( mkModuleName )
import RdrHsSyn	( mkHsIntegral, mkHsFractional, mkClassDecl, mkTyData )
import OccName
import SrcLoc	( SrcLoc, generatedSrcLoc )
import TyCon	( DataConDetails(..) )
import Type	( Type )
import BasicTypes( Boxity(..), RecFlag(Recursive), 
		   NewOrData(..), StrictnessMark(..) )
import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) )
import HsDecls ( CImportSpec(..), ForeignImport(..), ForeignDecl(..) )
import FastString( FastString, mkFastString, nilFS )
import Char 	( ord, isAscii, isAlphaNum, isAlpha )
import List	( partition )
import ErrUtils (Message)
import Outputable


-------------------------------------------------------------------
convertToHsDecls :: [Meta.Dec] -> [Either (HsDecl RdrName) Message]
convertToHsDecls ds = map cvt_top ds


cvt_top :: Meta.Dec -> Either (HsDecl RdrName) Message
cvt_top d@(Val _ _ _) = Left $ ValD (cvtd d)
cvt_top d@(Fun _ _)   = Left $ ValD (cvtd d)
 
cvt_top (TySyn tc tvs rhs)
  = Left $ TyClD (TySynonym (tconName tc) (cvt_tvs tvs) (cvtType rhs) loc0)

cvt_top (Data tc tvs constrs derivs)
  = Left $ TyClD (mkTyData DataType 
                           (noContext, tconName tc, cvt_tvs tvs)
                           (DataCons (map mk_con constrs))
                           (mk_derivs derivs) loc0)
  where
    mk_con (Constr c tys)
	= ConDecl (cName c) noExistentials noContext
		    (PrefixCon (map mk_arg tys)) loc0

    mk_arg ty = BangType NotMarkedStrict (cvtType ty)

    mk_derivs [] = Nothing
    mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs]

cvt_top (Class ctxt cl tvs decs)
  = Left $ TyClD (mkClassDecl (cvt_context ctxt, tconName cl, cvt_tvs tvs)
                              noFunDeps
                              sigs (Just binds) loc0)
  where
    (binds,sigs) = cvtBindsAndSigs decs

cvt_top (Instance tys ty decs)
  = Left $ InstD (InstDecl inst_ty binds sigs Nothing loc0)
  where
    (binds, sigs) = cvtBindsAndSigs decs
    inst_ty = HsForAllTy Nothing 
			 (cvt_context tys) 
			 (HsPredTy (cvt_pred ty))

cvt_top (Proto nm typ) = Left $ SigD (Sig (vName nm) (cvtType typ) loc0)

cvt_top (Foreign (Import callconv safety from nm typ))
 = case parsed of
       Just (c_header, cis) ->
           let i = CImport callconv' safety' c_header nilFS cis
           in Left $ ForD (ForeignImport (vName nm) (cvtType typ) i False loc0)
       Nothing -> Right $     text (show from)
                          <+> ptext SLIT("is not a valid ccall impent")
    where callconv' = case callconv of
                          CCall -> CCallConv
                          StdCall -> StdCallConv
          safety' = case safety of
                        Unsafe     -> PlayRisky
                        Safe       -> PlaySafe False
                        Threadsafe -> PlaySafe True
          parsed = parse_ccall_impent nm from

parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
parse_ccall_impent nm s
 = case lex_ccall_impent s of
       Just ["dynamic"] -> Just (nilFS, CFunction DynamicTarget)
       Just ["wrapper"] -> Just (nilFS, CWrapper)
       Just ("static":ts) -> parse_ccall_impent_static nm ts
       Just ts -> parse_ccall_impent_static nm ts
       Nothing -> Nothing

parse_ccall_impent_static :: String
                          -> [String]
                          -> Maybe (FastString, CImportSpec)
parse_ccall_impent_static nm ts
 = let ts' = case ts of
                 [       "&", cid] -> [       cid]
                 [fname, "&"     ] -> [fname     ]
                 [fname, "&", cid] -> [fname, cid]
                 _                 -> ts
   in case ts' of
          [       cid] | is_cid cid -> Just (nilFS,              mk_cid cid)
          [fname, cid] | is_cid cid -> Just (mkFastString fname, mk_cid cid)
          [          ]              -> Just (nilFS,              mk_cid nm)
          [fname     ]              -> Just (mkFastString fname, mk_cid nm)
          _                         -> Nothing
    where is_cid :: String -> Bool
          is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_')
          mk_cid :: String -> CImportSpec
          mk_cid  = CFunction . StaticTarget . mkFastString

lex_ccall_impent :: String -> Maybe [String]
lex_ccall_impent "" = Just []
lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs
lex_ccall_impent (' ':xs) = lex_ccall_impent xs
lex_ccall_impent ('\t':xs) = lex_ccall_impent xs
lex_ccall_impent xs = case span is_valid xs of
                          ("", _) -> Nothing
                          (t, xs') -> fmap (t:) $ lex_ccall_impent xs'
    where is_valid :: Char -> Bool
          is_valid c = isAscii c && (isAlphaNum c || c `elem` "._")

noContext      = []
noExistentials = []
noFunDeps      = []

-------------------------------------------------------------------
convertToHsExpr :: Meta.Exp -> HsExpr RdrName
convertToHsExpr = cvt

cvt (Var s) 	  = HsVar(vName s)
cvt (Con s) 	  = HsVar(cName s)
cvt (Lit l) 
  | overloadedLit l = HsOverLit (cvtOverLit l)
  | otherwise	    = HsLit (cvtLit l)

cvt (App x y)     = HsApp (cvt x) (cvt y)
cvt (Lam ps e)    = HsLam (mkSimpleMatch (map cvtp ps) (cvt e) void loc0)
cvt (Tup es)	  = ExplicitTuple(map cvt es) Boxed
cvt (Cond x y z)  = HsIf (cvt x) (cvt y) (cvt z) loc0
cvt (Let ds e)	  = HsLet (cvtdecs ds) (cvt e)
cvt (Case e ms)   = HsCase (cvt e) (map cvtm ms) loc0
cvt (Do ss)	  = HsDo DoExpr (cvtstmts ss) [] void loc0
cvt (Comp ss)     = HsDo ListComp (cvtstmts ss) [] void loc0
cvt (ArithSeq dd) = ArithSeqIn (cvtdd dd)
cvt (ListExp xs)  = ExplicitList void (map cvt xs)
cvt (Infix (Just x) s (Just y))
    = HsPar (OpApp (cvt x) (HsVar(vName s)) undefined (cvt y))
cvt (Infix Nothing  s (Just y)) = SectionR (HsVar(vName s)) (cvt y)
cvt (Infix (Just x) s Nothing ) = SectionL (cvt x) (HsVar(vName s))
cvt (Infix Nothing  s Nothing ) = HsVar(vName s) -- Can I indicate this is an infix thing?
cvt (SigExp e t)		= ExprWithTySig (cvt e) (cvtType t)

cvtdecs :: [Meta.Dec] -> HsBinds RdrName
cvtdecs [] = EmptyBinds
cvtdecs ds = MonoBind binds sigs Recursive
	   where
	     (binds, sigs) = cvtBindsAndSigs ds

cvtBindsAndSigs ds 
  = (cvtds non_sigs, map cvtSig sigs)
  where 
    (sigs, non_sigs) = partition sigP ds

cvtSig (Proto nm typ) = Sig (vName nm) (cvtType typ) loc0

cvtds :: [Meta.Dec] -> MonoBinds RdrName
cvtds []     = EmptyMonoBinds
cvtds (d:ds) = AndMonoBinds (cvtd d) (cvtds ds)

cvtd :: Meta.Dec -> MonoBinds RdrName
-- Used only for declarations in a 'let/where' clause,
-- not for top level decls
cvtd (Val (Pvar s) body ds) = FunMonoBind (vName s) False 
					  (panic "what now?") loc0
cvtd (Fun nm cls)   	    = FunMonoBind (vName nm) False (map cvtclause cls) loc0
cvtd (Val p body ds)	    = PatMonoBind (cvtp p) (GRHSs (cvtguard body) 
							  (cvtdecs ds) 
							  void) loc0
cvtd x = panic "Illegal kind of declaration in where clause" 


cvtclause :: Meta.Clause (Meta.Pat) (Meta.Exp) (Meta.Dec) -> Hs.Match RdrName
cvtclause (Clause ps body wheres)
    = Match (map cvtp ps) Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void)<commit_msg>[project @ 2002-12-11 14:02:28 by igloo] Handle bindings to just a pattern variable in cvtd.<commit_after>%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%

This module converts Template Haskell syntax into HsSyn


\begin{code}
module Convert( convertToHsExpr, convertToHsDecls ) where

#include "HsVersions.h"

import Language.Haskell.THSyntax as Meta

import HsSyn as Hs
	(	HsExpr(..), HsLit(..), ArithSeqInfo(..), 
		HsStmtContext(..), TyClDecl(..),
		Match(..), GRHSs(..), GRHS(..), HsPred(..),
		HsDecl(..), TyClDecl(..), InstDecl(..), ConDecl(..),
		Stmt(..), HsBinds(..), MonoBinds(..), Sig(..),
		Pat(..), HsConDetails(..), HsOverLit, BangType(..),
		placeHolderType, HsType(..), HsTupCon(..),
		HsTyVarBndr(..), HsContext,
		mkSimpleMatch
	) 

import RdrName	( RdrName, mkRdrUnqual, mkRdrQual, mkOrig )
import Module   ( mkModuleName )
import RdrHsSyn	( mkHsIntegral, mkHsFractional, mkClassDecl, mkTyData )
import OccName
import SrcLoc	( SrcLoc, generatedSrcLoc )
import TyCon	( DataConDetails(..) )
import Type	( Type )
import BasicTypes( Boxity(..), RecFlag(Recursive), 
		   NewOrData(..), StrictnessMark(..) )
import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) )
import HsDecls ( CImportSpec(..), ForeignImport(..), ForeignDecl(..) )
import FastString( FastString, mkFastString, nilFS )
import Char 	( ord, isAscii, isAlphaNum, isAlpha )
import List	( partition )
import ErrUtils (Message)
import Outputable


-------------------------------------------------------------------
convertToHsDecls :: [Meta.Dec] -> [Either (HsDecl RdrName) Message]
convertToHsDecls ds = map cvt_top ds


cvt_top :: Meta.Dec -> Either (HsDecl RdrName) Message
cvt_top d@(Val _ _ _) = Left $ ValD (cvtd d)
cvt_top d@(Fun _ _)   = Left $ ValD (cvtd d)
 
cvt_top (TySyn tc tvs rhs)
  = Left $ TyClD (TySynonym (tconName tc) (cvt_tvs tvs) (cvtType rhs) loc0)

cvt_top (Data tc tvs constrs derivs)
  = Left $ TyClD (mkTyData DataType 
                           (noContext, tconName tc, cvt_tvs tvs)
                           (DataCons (map mk_con constrs))
                           (mk_derivs derivs) loc0)
  where
    mk_con (Constr c tys)
	= ConDecl (cName c) noExistentials noContext
		    (PrefixCon (map mk_arg tys)) loc0

    mk_arg ty = BangType NotMarkedStrict (cvtType ty)

    mk_derivs [] = Nothing
    mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs]

cvt_top (Class ctxt cl tvs decs)
  = Left $ TyClD (mkClassDecl (cvt_context ctxt, tconName cl, cvt_tvs tvs)
                              noFunDeps
                              sigs (Just binds) loc0)
  where
    (binds,sigs) = cvtBindsAndSigs decs

cvt_top (Instance tys ty decs)
  = Left $ InstD (InstDecl inst_ty binds sigs Nothing loc0)
  where
    (binds, sigs) = cvtBindsAndSigs decs
    inst_ty = HsForAllTy Nothing 
			 (cvt_context tys) 
			 (HsPredTy (cvt_pred ty))

cvt_top (Proto nm typ) = Left $ SigD (Sig (vName nm) (cvtType typ) loc0)

cvt_top (Foreign (Import callconv safety from nm typ))
 = case parsed of
       Just (c_header, cis) ->
           let i = CImport callconv' safety' c_header nilFS cis
           in Left $ ForD (ForeignImport (vName nm) (cvtType typ) i False loc0)
       Nothing -> Right $     text (show from)
                          <+> ptext SLIT("is not a valid ccall impent")
    where callconv' = case callconv of
                          CCall -> CCallConv
                          StdCall -> StdCallConv
          safety' = case safety of
                        Unsafe     -> PlayRisky
                        Safe       -> PlaySafe False
                        Threadsafe -> PlaySafe True
          parsed = parse_ccall_impent nm from

parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
parse_ccall_impent nm s
 = case lex_ccall_impent s of
       Just ["dynamic"] -> Just (nilFS, CFunction DynamicTarget)
       Just ["wrapper"] -> Just (nilFS, CWrapper)
       Just ("static":ts) -> parse_ccall_impent_static nm ts
       Just ts -> parse_ccall_impent_static nm ts
       Nothing -> Nothing

parse_ccall_impent_static :: String
                          -> [String]
                          -> Maybe (FastString, CImportSpec)
parse_ccall_impent_static nm ts
 = let ts' = case ts of
                 [       "&", cid] -> [       cid]
                 [fname, "&"     ] -> [fname     ]
                 [fname, "&", cid] -> [fname, cid]
                 _                 -> ts
   in case ts' of
          [       cid] | is_cid cid -> Just (nilFS,              mk_cid cid)
          [fname, cid] | is_cid cid -> Just (mkFastString fname, mk_cid cid)
          [          ]              -> Just (nilFS,              mk_cid nm)
          [fname     ]              -> Just (mkFastString fname, mk_cid nm)
          _                         -> Nothing
    where is_cid :: String -> Bool
          is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_')
          mk_cid :: String -> CImportSpec
          mk_cid  = CFunction . StaticTarget . mkFastString

lex_ccall_impent :: String -> Maybe [String]
lex_ccall_impent "" = Just []
lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs
lex_ccall_impent (' ':xs) = lex_ccall_impent xs
lex_ccall_impent ('\t':xs) = lex_ccall_impent xs
lex_ccall_impent xs = case span is_valid xs of
                          ("", _) -> Nothing
                          (t, xs') -> fmap (t:) $ lex_ccall_impent xs'
    where is_valid :: Char -> Bool
          is_valid c = isAscii c && (isAlphaNum c || c `elem` "._")

noContext      = []
noExistentials = []
noFunDeps      = []

-------------------------------------------------------------------
convertToHsExpr :: Meta.Exp -> HsExpr RdrName
convertToHsExpr = cvt

cvt (Var s) 	  = HsVar(vName s)
cvt (Con s) 	  = HsVar(cName s)
cvt (Lit l) 
  | overloadedLit l = HsOverLit (cvtOverLit l)
  | otherwise	    = HsLit (cvtLit l)

cvt (App x y)     = HsApp (cvt x) (cvt y)
cvt (Lam ps e)    = HsLam (mkSimpleMatch (map cvtp ps) (cvt e) void loc0)
cvt (Tup es)	  = ExplicitTuple(map cvt es) Boxed
cvt (Cond x y z)  = HsIf (cvt x) (cvt y) (cvt z) loc0
cvt (Let ds e)	  = HsLet (cvtdecs ds) (cvt e)
cvt (Case e ms)   = HsCase (cvt e) (map cvtm ms) loc0
cvt (Do ss)	  = HsDo DoExpr (cvtstmts ss) [] void loc0
cvt (Comp ss)     = HsDo ListComp (cvtstmts ss) [] void loc0
cvt (ArithSeq dd) = ArithSeqIn (cvtdd dd)
cvt (ListExp xs)  = ExplicitList void (map cvt xs)
cvt (Infix (Just x) s (Just y))
    = HsPar (OpApp (cvt x) (HsVar(vName s)) undefined (cvt y))
cvt (Infix Nothing  s (Just y)) = SectionR (HsVar(vName s)) (cvt y)
cvt (Infix (Just x) s Nothing ) = SectionL (cvt x) (HsVar(vName s))
cvt (Infix Nothing  s Nothing ) = HsVar(vName s) -- Can I indicate this is an infix thing?
cvt (SigExp e t)		= ExprWithTySig (cvt e) (cvtType t)

cvtdecs :: [Meta.Dec] -> HsBinds RdrName
cvtdecs [] = EmptyBinds
cvtdecs ds = MonoBind binds sigs Recursive
	   where
	     (binds, sigs) = cvtBindsAndSigs ds

cvtBindsAndSigs ds 
  = (cvtds non_sigs, map cvtSig sigs)
  where 
    (sigs, non_sigs) = partition sigP ds

cvtSig (Proto nm typ) = Sig (vName nm) (cvtType typ) loc0

cvtds :: [Meta.Dec] -> MonoBinds RdrName
cvtds []     = EmptyMonoBinds
cvtds (d:ds) = AndMonoBinds (cvtd d) (cvtds ds)

cvtd :: Meta.Dec -> MonoBinds RdrName
-- Used only for declarations in a 'let/where' clause,
-- not for top level decls
cvtd (Val (Pvar s) body ds) = FunMonoBind (vName s) False 
					  [cvtclause (Clause [] body ds)] loc0
cvtd (Fun nm cls)   	    = FunMonoBind (vName nm) False (map cvtclause cls) loc0
cvtd (Val p body ds)	    = PatMonoBind (cvtp p) (GRHSs (cvtguard body) 
							  (cvtdecs ds) 
							  void) loc0
cvtd x = panic "Illegal kind of declaration in where clause" 


cvtclause :: Meta.Clause (Meta.Pat) (Meta.Exp) (Meta.Dec) -> Hs.Match RdrName
cvtclause (Clause ps body wheres)
    = Match (map cvtp ps) Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void)
{'fraction_non_alphanumeric': 0.13307501746808106, 'fraction_numerical': 0.003938258273518389, 'mean_word_length': 2.304785894206549, 'pattern_counts': {'":': 4, '<': 7, '<?xml version=': 0, '>': 81, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 10, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5370919', 'n_tokens_mistral': 5983, 'n_tokens_neox': 5695, 'n_words': 1685}