------------------------------------------------------------------------
-- | Strictification of Haskell code
------------------------------------------------------------------------

module Agda.Compiler.MAlonzo.Strict where

import Agda.Utils.Haskell.Syntax

-- | The function 'makeStrict' makes every function argument, case and
-- generator pattern, and 'LocalBind' binding strict (except for those
-- patterns that are marked as irrefutable, and anything in a
-- 'FakeDecl' or 'FakeExp'). Note that only the outermost patterns are
-- made strict.

class MakeStrict a where
  makeStrict :: a -> a

instance MakeStrict a => MakeStrict [a] where
  makeStrict :: [a] -> [a]
makeStrict = forall a b. (a -> b) -> [a] -> [b]
map forall a. MakeStrict a => a -> a
makeStrict

instance MakeStrict a => MakeStrict (Maybe a) where
  makeStrict :: Maybe a -> Maybe a
makeStrict = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. MakeStrict a => a -> a
makeStrict

instance MakeStrict Module where
  makeStrict :: Module -> Module
makeStrict (Module ModuleName
m [ModulePragma]
pragmas [ImportDecl]
imps [Decl]
decls) =
    ModuleName -> [ModulePragma] -> [ImportDecl] -> [Decl] -> Module
Module ModuleName
m [ModulePragma]
pragmas [ImportDecl]
imps (forall a. MakeStrict a => a -> a
makeStrict [Decl]
decls)

instance MakeStrict Decl where
  makeStrict :: Decl -> Decl
makeStrict = \case
    d :: Decl
d@TypeDecl{}      -> Decl
d
    d :: Decl
d@DataDecl{}      -> Decl
d
    d :: Decl
d@TypeSig{}       -> Decl
d
    FunBind [Match]
ms        -> [Match] -> Decl
FunBind (forall a. MakeStrict a => a -> a
makeStrict [Match]
ms)
    LocalBind Strictness
s Name
f Rhs
rhs -> Strictness -> Name -> Rhs -> Decl
LocalBind Strictness
Strict Name
f (forall a. MakeStrict a => a -> a
makeStrict Rhs
rhs)
    d :: Decl
d@PatSyn{}        -> Decl
d
    d :: Decl
d@FakeDecl{}      -> Decl
d
    d :: Decl
d@Comment{}       -> Decl
d

instance MakeStrict Match where
  makeStrict :: Match -> Match
makeStrict (Match Name
f [Pat]
ps Rhs
rhs Maybe Binds
wh) =
    Name -> [Pat] -> Rhs -> Maybe Binds -> Match
Match Name
f (forall a. MakeStrict a => a -> a
makeStrict [Pat]
ps) (forall a. MakeStrict a => a -> a
makeStrict Rhs
rhs) (forall a. MakeStrict a => a -> a
makeStrict Maybe Binds
wh)

instance MakeStrict Pat where
  makeStrict :: Pat -> Pat
makeStrict = \case
    p :: Pat
p@PVar{}       -> Pat -> Pat
PBangPat Pat
p
    p :: Pat
p@PLit{}       -> Pat -> Pat
PBangPat Pat
p
    PAsPat Name
x Pat
p     -> Name -> Pat -> Pat
PAsPat Name
x (forall a. MakeStrict a => a -> a
makeStrict Pat
p)
    p :: Pat
p@PWildCard{}  -> Pat -> Pat
PBangPat Pat
p
    p :: Pat
p@PBangPat{}   -> Pat
p
    p :: Pat
p@PApp{}       -> Pat -> Pat
PBangPat Pat
p
    PatTypeSig Pat
p Type
t -> Pat -> Type -> Pat
PatTypeSig (forall a. MakeStrict a => a -> a
makeStrict Pat
p) Type
t
    p :: Pat
p@PIrrPat{}    -> Pat
p

instance MakeStrict Binds where
  makeStrict :: Binds -> Binds
makeStrict (BDecls [Decl]
ds) = [Decl] -> Binds
BDecls (forall a. MakeStrict a => a -> a
makeStrict [Decl]
ds)

instance MakeStrict Rhs where
  makeStrict :: Rhs -> Rhs
makeStrict (UnGuardedRhs Exp
e) = Exp -> Rhs
UnGuardedRhs (forall a. MakeStrict a => a -> a
makeStrict Exp
e)
  makeStrict (GuardedRhss [GuardedRhs]
rs) = [GuardedRhs] -> Rhs
GuardedRhss (forall a. MakeStrict a => a -> a
makeStrict [GuardedRhs]
rs)

instance MakeStrict GuardedRhs where
  makeStrict :: GuardedRhs -> GuardedRhs
makeStrict (GuardedRhs [Stmt]
ss Exp
e) =
    [Stmt] -> Exp -> GuardedRhs
GuardedRhs (forall a. MakeStrict a => a -> a
makeStrict [Stmt]
ss) (forall a. MakeStrict a => a -> a
makeStrict Exp
e)

instance MakeStrict Stmt where
  makeStrict :: Stmt -> Stmt
makeStrict = \case
    Qualifier Exp
e   -> Exp -> Stmt
Qualifier (forall a. MakeStrict a => a -> a
makeStrict Exp
e)
    Generator Pat
p Exp
e -> Pat -> Exp -> Stmt
Generator (forall a. MakeStrict a => a -> a
makeStrict Pat
p) (forall a. MakeStrict a => a -> a
makeStrict Exp
e)

instance MakeStrict Exp where
  makeStrict :: Exp -> Exp
makeStrict Exp
e =
    case Exp
e of
      Var{}           -> Exp
e
      Con{}           -> Exp
e
      Lit{}           -> Exp
e
      InfixApp Exp
a QOp
op Exp
b -> Exp -> QOp -> Exp -> Exp
InfixApp (forall a. MakeStrict a => a -> a
makeStrict Exp
a) QOp
op (forall a. MakeStrict a => a -> a
makeStrict Exp
b)
      Ann Exp
e Type
ty        -> Exp -> Type -> Exp
Ann (forall a. MakeStrict a => a -> a
makeStrict Exp
e) Type
ty
      App Exp
a Exp
b         -> Exp -> Exp -> Exp
App (forall a. MakeStrict a => a -> a
makeStrict Exp
a) (forall a. MakeStrict a => a -> a
makeStrict Exp
b)
      Lambda [Pat]
ps Exp
e     -> [Pat] -> Exp -> Exp
Lambda (forall a. MakeStrict a => a -> a
makeStrict [Pat]
ps) (forall a. MakeStrict a => a -> a
makeStrict Exp
e)
      Let Binds
bs Exp
e        -> Binds -> Exp -> Exp
Let (forall a. MakeStrict a => a -> a
makeStrict Binds
bs) (forall a. MakeStrict a => a -> a
makeStrict Exp
e)
      If Exp
a Exp
b Exp
c        -> Exp -> Exp -> Exp -> Exp
If (forall a. MakeStrict a => a -> a
makeStrict Exp
a) (forall a. MakeStrict a => a -> a
makeStrict Exp
b) (forall a. MakeStrict a => a -> a
makeStrict Exp
c)
      Case Exp
e [Alt]
bs       -> Exp -> [Alt] -> Exp
Case (forall a. MakeStrict a => a -> a
makeStrict Exp
e) (forall a. MakeStrict a => a -> a
makeStrict [Alt]
bs)
      ExpTypeSig Exp
e Type
t  -> Exp -> Type -> Exp
ExpTypeSig (forall a. MakeStrict a => a -> a
makeStrict Exp
e) Type
t
      NegApp Exp
e        -> Exp -> Exp
NegApp (forall a. MakeStrict a => a -> a
makeStrict Exp
e)
      FakeExp String
s       -> String -> Exp
FakeExp String
s

instance MakeStrict Alt where
  makeStrict :: Alt -> Alt
makeStrict (Alt Pat
pat Rhs
rhs Maybe Binds
wh) =
    Pat -> Rhs -> Maybe Binds -> Alt
Alt (forall a. MakeStrict a => a -> a
makeStrict Pat
pat) (forall a. MakeStrict a => a -> a
makeStrict Rhs
rhs) (forall a. MakeStrict a => a -> a
makeStrict Maybe Binds
wh)