<commit_before>{-# LANGUAGE PatternGuards, FlexibleInstances, TypeSynonymInstances #-}
-- | Duck Intermediate Representation
-- 
-- Conversion of "Ast" into intermediate functional representation.

module Ir 
  ( Decl(..)
  , Exp(..)
  , TypePat(..), TypeFun(..)
  , prog
  ) where

import Data.List
import Data.Function
import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Foldable as Fold
import Data.Monoid

import Util
import Pretty
import SrcLoc
import Stage
import Var
import IrType
import Prims hiding (typeInt, typeChar)
import qualified Ast
import ParseOps

-- |Top-level declaration
data Decl
  = LetD !(Loc Var) Exp                 -- ^ Single symbol definition, either a variable or a function without a corresponding type specification (with 'Lambda'): @VAR = EXP@
  | LetM [Loc Var] Exp                  -- ^ Tuple assignment/definition, from a pattern definition with 0 or more than 1 variable: @(VARs) = EXP@
  | ExpD Exp                            -- ^ Top level expression: @EXP@
  | Over !(Loc Var) !TypePat Exp        -- ^ Overload paired type declaration and definition: @VAR :: TYPE = EXP@
  | Data !(Loc CVar) [Var] [(Loc CVar, [TypePat])] -- ^ Datatype declaration: @data CVAR VARs = { CVAR TYPEs ; ... }@
  deriving Show

type Trans = Maybe Var

-- |Expression
data Exp
  = ExpLoc SrcLoc !Exp                  -- ^ Meta source location information, present at every non-generated level
  | Int !Int
  | Char !Char
  | Var !Var
  | Lambda Trans !Var Exp               -- ^ Simple lambda expression: @[TRANS] VAR -> EXP@
  | Apply Exp Exp                       -- ^ Application: @EXP EXP@
  | Let Trans !Var Exp Exp              -- ^ Simple variable assignment: @let VAR = EXP in EXP@
  | Case Trans Var [(CVar, [Var], Exp)] (Maybe Exp) -- ^ @case VAR of { CVAR VARs -> EXP ; ... [ ; _ -> EXP ] }@
  | Prim !Prim [Exp]                    -- ^ Primitive function call: @PRIM EXPs@
  | Spec Exp !TypePat                   -- ^ Type specification: @EXP :: TYPE@
  deriving Show

-- Ast to IR conversion

data Pattern = Pat 
  { patVars :: [Var]
  , patSpec :: [TypePat]
  , patCons :: Maybe (CVar, [Pattern])
  , patCheck :: Maybe (Var -> Exp) -- :: Bool
  }

data CaseTail
  = CaseGroup [Switch]
  | CaseBody Exp

data Case = CaseMatch
  { casePat :: [Pattern]
  , _caseLets :: Exp -> Exp
  , _caseNext :: CaseTail
  }

data Switch = Switch 
  { _switchVal :: [(Trans, Exp)]
  , switchCases :: [Case]
  }

irError :: Pretty s => SrcLoc -> s -> a
irError l = fatal . locMsg l

dupError :: Pretty v => v -> SrcLoc -> SrcLoc -> a
dupError v n o = irError n $ "duplicate definition of" <+> quoted v <> (", previously declared at" <&+> o)

prog_vars :: Ast.Prog -> InScopeSet
prog_vars = foldl' decl_vars Set.empty . map unLoc

decl_vars :: InScopeSet -> Ast.Decl -> InScopeSet
decl_vars s (Ast.SpecD (L _ v) _) = Set.insert v s 
decl_vars s (Ast.DefD (L _ v) _ _) = Set.insert v s 
decl_vars s (Ast.LetD p _) = pattern_vars s p
decl_vars s (Ast.ExpD _) = s
decl_vars s (Ast.Data _ _ _) = s
decl_vars s (Ast.Infix _ _) = s
decl_vars s (Ast.Import _) = s

pattern_vars :: InScopeSet -> Ast.Pattern -> InScopeSet
pattern_vars s Ast.PatAny = s
pattern_vars s (Ast.PatVar v) = Set.insert v s
pattern_vars s (Ast.PatInt _) = s
pattern_vars s (Ast.PatChar _) = s
pattern_vars s (Ast.PatString _) = s
pattern_vars s (Ast.PatCons _ pl) = foldl' pattern_vars s pl
pattern_vars s (Ast.PatOps o) = Fold.foldl' pattern_vars s o
pattern_vars s (Ast.PatList pl) = foldl' pattern_vars s pl
pattern_vars s (Ast.PatAs v p) = pattern_vars (Set.insert v s) p
pattern_vars s (Ast.PatSpec p _) = pattern_vars s p
pattern_vars s (Ast.PatLambda pl p) = foldl' pattern_vars (pattern_vars s p) pl
pattern_vars s (Ast.PatTrans _ p) = pattern_vars s p
pattern_vars s (Ast.PatLoc _ p) = pattern_vars s p

prog_precs :: PrecEnv -> Ast.Prog -> PrecEnv
prog_precs = foldl' set_precs where
  set_precs s (L l (Ast.Infix p vl)) = foldl' (\s v -> Map.insertWithKey check v p s) s vl where
    check v new old
      | new == old = new
      | otherwise = irError l $ "conflicting fixity declaration for" <+> quoted v <+> "(previously" <+> old <+> ")"
  set_precs s _ = s

instance HasVar Exp where
  unVar (Var v) = Just v
  unVar (ExpLoc _ e) = unVar e
  unVar _ = Nothing

letVarIf :: Trans -> Var -> Exp -> Exp -> Exp
letVarIf tr var val exp
  | Just v <- unVar val
  , v == var = exp
  | otherwise = Let tr var val exp

anyPat :: Pattern
anyPat = Pat [] [] Nothing Nothing

instance HasVar Pattern where
  unVar (Pat{ patVars = v:_ }) = Just v
  unVar _ = Nothing

consPat :: CVar -> [Pattern] -> Pattern
consPat c pl = Pat [] [] (Just (c,pl)) Nothing

addPatVar :: Var -> Pattern -> Pattern
addPatVar v p = p { patVars = v : patVars p }

addPatSpec :: TypePat -> Pattern -> Pattern
addPatSpec t p = p { patSpec = t : patSpec p }

patLets :: Trans -> Var -> Pattern -> Exp -> Exp
patLets tr var (Pat vl tl _ _) e = case (vl', tl) of
  ([],[]) -> e
  ([],_) -> Let tr ignored spec e
  (v:vl,_) -> letVarIf tr v spec $ foldr (\v -> Let tr v $ Var var) e vl
  where 
    spec = foldl Spec (Var var) tl
    (_:vl') = nub (var:vl)

patName :: InScopeSet -> Pattern -> (InScopeSet, Var)
patName s (Pat{ patVars = v:_ }) = (s, v)
patName s (Pat{ patVars = [] }) = fresh s 

patNames :: InScopeSet -> Int -> [Pattern] -> (InScopeSet, [Var])
patNames s 0 _ = (s, [])
patNames s n [] = freshVars s n
patNames s n (p:pl) = second (v:) $ patNames s' (pred n) pl where (s',v) = patName s p 

patsNames :: InScopeSet -> Int -> [[Pattern]] -> (InScopeSet, [Var])
patsNames s n [p] = patNames s n p
patsNames s n _ = freshVars s n

unPatTrans :: Ast.Pattern -> (Trans, Ast.Pattern)
unPatTrans (Ast.PatTrans t p) = (Just t, p)
unPatTrans (Ast.PatLoc l p) = fmap (Ast.PatLoc l) $ unPatTrans p
unPatTrans p = (Nothing, p)

mapss :: (a -> (InScopeSet, b)) -> [a] -> (InScopeSet, [b])
--mapss f = first Set.unions . unzipWith f l
mapss f = mapAccumL (\s -> first (Set.union s) . f) Set.empty

prog :: PrecEnv -> ModuleName -> Ast.Prog -> (PrecEnv, (ModuleName, [Decl]))
prog pprec name p = (precs, (name, decls p)) where
  precs = prog_precs pprec p
  globals = prog_vars p

  -- Declaration conversion can turn multiple Ast.Decls into a single Ir.Decl, as with
  --   f :: <type>
  --   f x = ...
  decls :: [Loc Ast.Decl] -> [Decl]
  decls [] = []
  decls decs@(L _ (Ast.DefD (L _ f) _ _):_) = LetD (L l f) body : decls rest where
    (L l body, rest) = funcases globals f isfcase decs
    isfcase (L l (Ast.DefD (L _ f') a b)) | f == f' = Just (L l (a,b))<commit_msg>Ir: rename some functions to use camlCase<commit_after>{-# LANGUAGE PatternGuards, FlexibleInstances, TypeSynonymInstances #-}
-- | Duck Intermediate Representation
-- 
-- Conversion of "Ast" into intermediate functional representation.

module Ir 
  ( Decl(..)
  , Exp(..)
  , TypePat(..), TypeFun(..)
  , prog
  ) where

import Data.List
import Data.Function
import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Foldable as Fold
import Data.Monoid

import Util
import Pretty
import SrcLoc
import Stage
import Var
import IrType
import Prims hiding (typeInt, typeChar)
import qualified Ast
import ParseOps

-- |Top-level declaration
data Decl
  = LetD !(Loc Var) Exp                 -- ^ Single symbol definition, either a variable or a function without a corresponding type specification (with 'Lambda'): @VAR = EXP@
  | LetM [Loc Var] Exp                  -- ^ Tuple assignment/definition, from a pattern definition with 0 or more than 1 variable: @(VARs) = EXP@
  | ExpD Exp                            -- ^ Top level expression: @EXP@
  | Over !(Loc Var) !TypePat Exp        -- ^ Overload paired type declaration and definition: @VAR :: TYPE = EXP@
  | Data !(Loc CVar) [Var] [(Loc CVar, [TypePat])] -- ^ Datatype declaration: @data CVAR VARs = { CVAR TYPEs ; ... }@
  deriving Show

type Trans = Maybe Var

-- |Expression
data Exp
  = ExpLoc SrcLoc !Exp                  -- ^ Meta source location information, present at every non-generated level
  | Int !Int
  | Char !Char
  | Var !Var
  | Lambda Trans !Var Exp               -- ^ Simple lambda expression: @[TRANS] VAR -> EXP@
  | Apply Exp Exp                       -- ^ Application: @EXP EXP@
  | Let Trans !Var Exp Exp              -- ^ Simple variable assignment: @let VAR = EXP in EXP@
  | Case Trans Var [(CVar, [Var], Exp)] (Maybe Exp) -- ^ @case VAR of { CVAR VARs -> EXP ; ... [ ; _ -> EXP ] }@
  | Prim !Prim [Exp]                    -- ^ Primitive function call: @PRIM EXPs@
  | Spec Exp !TypePat                   -- ^ Type specification: @EXP :: TYPE@
  deriving Show

-- Ast to IR conversion

data Pattern = Pat 
  { patVars :: [Var]
  , patSpec :: [TypePat]
  , patCons :: Maybe (CVar, [Pattern])
  , patCheck :: Maybe (Var -> Exp) -- :: Bool
  }

data CaseTail
  = CaseGroup [Switch]
  | CaseBody Exp

data Case = CaseMatch
  { casePat :: [Pattern]
  , _caseLets :: Exp -> Exp
  , _caseNext :: CaseTail
  }

data Switch = Switch 
  { _switchVal :: [(Trans, Exp)]
  , switchCases :: [Case]
  }

irError :: Pretty s => SrcLoc -> s -> a
irError l = fatal . locMsg l

dupError :: Pretty v => v -> SrcLoc -> SrcLoc -> a
dupError v n o = irError n $ "duplicate definition of" <+> quoted v <> (", previously declared at" <&+> o)

progVars :: Ast.Prog -> InScopeSet
progVars = foldl' declVars Set.empty . map unLoc

declVars :: InScopeSet -> Ast.Decl -> InScopeSet
declVars s (Ast.SpecD (L _ v) _) = Set.insert v s 
declVars s (Ast.DefD (L _ v) _ _) = Set.insert v s 
declVars s (Ast.LetD p _) = patternVars s p
declVars s (Ast.ExpD _) = s
declVars s (Ast.Data _ _ _) = s
declVars s (Ast.Infix _ _) = s
declVars s (Ast.Import _) = s

patternVars :: InScopeSet -> Ast.Pattern -> InScopeSet
patternVars s Ast.PatAny = s
patternVars s (Ast.PatVar v) = Set.insert v s
patternVars s (Ast.PatInt _) = s
patternVars s (Ast.PatChar _) = s
patternVars s (Ast.PatString _) = s
patternVars s (Ast.PatCons _ pl) = foldl' patternVars s pl
patternVars s (Ast.PatOps o) = Fold.foldl' patternVars s o
patternVars s (Ast.PatList pl) = foldl' patternVars s pl
patternVars s (Ast.PatAs v p) = patternVars (Set.insert v s) p
patternVars s (Ast.PatSpec p _) = patternVars s p
patternVars s (Ast.PatLambda pl p) = foldl' patternVars (patternVars s p) pl
patternVars s (Ast.PatTrans _ p) = patternVars s p
patternVars s (Ast.PatLoc _ p) = patternVars s p

progPrecs :: PrecEnv -> Ast.Prog -> PrecEnv
progPrecs = foldl' set_precs where
  set_precs s (L l (Ast.Infix p vl)) = foldl' (\s v -> Map.insertWithKey check v p s) s vl where
    check v new old
      | new == old = new
      | otherwise = irError l $ "conflicting fixity declaration for" <+> quoted v <+> "(previously" <+> old <+> ")"
  set_precs s _ = s

instance HasVar Exp where
  unVar (Var v) = Just v
  unVar (ExpLoc _ e) = unVar e
  unVar _ = Nothing

letVarIf :: Trans -> Var -> Exp -> Exp -> Exp
letVarIf tr var val exp
  | Just v <- unVar val
  , v == var = exp
  | otherwise = Let tr var val exp

anyPat :: Pattern
anyPat = Pat [] [] Nothing Nothing

instance HasVar Pattern where
  unVar (Pat{ patVars = v:_ }) = Just v
  unVar _ = Nothing

consPat :: CVar -> [Pattern] -> Pattern
consPat c pl = Pat [] [] (Just (c,pl)) Nothing

addPatVar :: Var -> Pattern -> Pattern
addPatVar v p = p { patVars = v : patVars p }

addPatSpec :: TypePat -> Pattern -> Pattern
addPatSpec t p = p { patSpec = t : patSpec p }

patLets :: Trans -> Var -> Pattern -> Exp -> Exp
patLets tr var (Pat vl tl _ _) e = case (vl', tl) of
  ([],[]) -> e
  ([],_) -> Let tr ignored spec e
  (v:vl,_) -> letVarIf tr v spec $ foldr (\v -> Let tr v $ Var var) e vl
  where 
    spec = foldl Spec (Var var) tl
    (_:vl') = nub (var:vl)

patName :: InScopeSet -> Pattern -> (InScopeSet, Var)
patName s (Pat{ patVars = v:_ }) = (s, v)
patName s (Pat{ patVars = [] }) = fresh s 

patNames :: InScopeSet -> Int -> [Pattern] -> (InScopeSet, [Var])
patNames s 0 _ = (s, [])
patNames s n [] = freshVars s n
patNames s n (p:pl) = second (v:) $ patNames s' (pred n) pl where (s',v) = patName s p 

patsNames :: InScopeSet -> Int -> [[Pattern]] -> (InScopeSet, [Var])
patsNames s n [p] = patNames s n p
patsNames s n _ = freshVars s n

unPatTrans :: Ast.Pattern -> (Trans, Ast.Pattern)
unPatTrans (Ast.PatTrans t p) = (Just t, p)
unPatTrans (Ast.PatLoc l p) = fmap (Ast.PatLoc l) $ unPatTrans p
unPatTrans p = (Nothing, p)

mapss :: (a -> (InScopeSet, b)) -> [a] -> (InScopeSet, [b])
--mapss f = first Set.unions . unzipWith f l
mapss f = mapAccumL (\s -> first (Set.union s) . f) Set.empty

prog :: PrecEnv -> ModuleName -> Ast.Prog -> (PrecEnv, (ModuleName, [Decl]))
prog pprec name p = (precs, (name, decls p)) where
  precs = progPrecs pprec p
  globals = progVars p

  -- Declaration conversion can turn multiple Ast.Decls into a single Ir.Decl, as with
  --   f :: <type>
  --   f x = ...
  decls :: [Loc Ast.Decl] -> [Decl]
  decls [] = []
  decls decs@(L _ (Ast.DefD (L _ f) _ _):_) = LetD (L l f) body : decls rest where
    (L l body, rest) = funcases globals f isfcase decs
    isfcase (L l (Ast.DefD (L _ f') a b)) | f == f' = Just (L l (a,b))
{'fraction_non_alphanumeric': 0.13424699023245248, 'fraction_numerical': 0.0004543045354736125, 'mean_word_length': 2.831737742964897, 'pattern_counts': {'":': 0, '<': 21, '<?xml version=': 0, '>': 129, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2695117', 'n_tokens_mistral': 4684, 'n_tokens_neox': 4612, 'n_words': 1693}