------------------------------------------------------------------------
-- | 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 = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map a -> a
forall a. MakeStrict a => a -> a
makeStrict

instance MakeStrict a => MakeStrict (Maybe a) where
  makeStrict :: Maybe a -> Maybe a
makeStrict = (a -> a) -> Maybe a -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
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 ([Decl] -> [Decl]
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 ([Match] -> [Match]
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 (Rhs -> Rhs
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 ([Pat] -> [Pat]
forall a. MakeStrict a => a -> a
makeStrict [Pat]
ps) (Rhs -> Rhs
forall a. MakeStrict a => a -> a
makeStrict Rhs
rhs) (Maybe Binds -> Maybe Binds
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 (Pat -> Pat
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 (Pat -> Pat
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 ([Decl] -> [Decl]
forall a. MakeStrict a => a -> a
makeStrict [Decl]
ds)

instance MakeStrict Rhs where
  makeStrict :: Rhs -> Rhs
makeStrict (UnGuardedRhs Exp
e) = Exp -> Rhs
UnGuardedRhs (Exp -> Exp
forall a. MakeStrict a => a -> a
makeStrict Exp
e)
  makeStrict (GuardedRhss [GuardedRhs]
rs) = [GuardedRhs] -> Rhs
GuardedRhss ([GuardedRhs] -> [GuardedRhs]
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 ([Stmt] -> [Stmt]
forall a. MakeStrict a => a -> a
makeStrict [Stmt]
ss) (Exp -> Exp
forall a. MakeStrict a => a -> a
makeStrict Exp
e)

instance MakeStrict Stmt where
  makeStrict :: Stmt -> Stmt
makeStrict = \case
    Qualifier Exp
e   -> Exp -> Stmt
Qualifier (Exp -> Exp
forall a. MakeStrict a => a -> a
makeStrict Exp
e)
    Generator Pat
p Exp
e -> Pat -> Exp -> Stmt
Generator (Pat -> Pat
forall a. MakeStrict a => a -> a
makeStrict Pat
p) (Exp -> Exp
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 (Exp -> Exp
forall a. MakeStrict a => a -> a
makeStrict Exp
a) QOp
op (Exp -> Exp
forall a. MakeStrict a => a -> a
makeStrict Exp
b)
      Ann Exp
e Type
ty        -> Exp -> Type -> Exp
Ann (Exp -> Exp
forall a. MakeStrict a => a -> a
makeStrict Exp
e) Type
ty
      App Exp
a Exp
b         -> Exp -> Exp -> Exp
App (Exp -> Exp
forall a. MakeStrict a => a -> a
makeStrict Exp
a) (Exp -> Exp
forall a. MakeStrict a => a -> a
makeStrict Exp
b)
      Lambda [Pat]
ps Exp
e     -> [Pat] -> Exp -> Exp
Lambda ([Pat] -> [Pat]
forall a. MakeStrict a => a -> a
makeStrict [Pat]
ps) (Exp -> Exp
forall a. MakeStrict a => a -> a
makeStrict Exp
e)
      Let Binds
bs Exp
e        -> Binds -> Exp -> Exp
Let (Binds -> Binds
forall a. MakeStrict a => a -> a
makeStrict Binds
bs) (Exp -> Exp
forall a. MakeStrict a => a -> a
makeStrict Exp
e)
      If Exp
a Exp
b Exp
c        -> Exp -> Exp -> Exp -> Exp
If (Exp -> Exp
forall a. MakeStrict a => a -> a
makeStrict Exp
a) (Exp -> Exp
forall a. MakeStrict a => a -> a
makeStrict Exp
b) (Exp -> Exp
forall a. MakeStrict a => a -> a
makeStrict Exp
c)
      Case Exp
e [Alt]
bs       -> Exp -> [Alt] -> Exp
Case (Exp -> Exp
forall a. MakeStrict a => a -> a
makeStrict Exp
e) ([Alt] -> [Alt]
forall a. MakeStrict a => a -> a
makeStrict [Alt]
bs)
      ExpTypeSig Exp
e Type
t  -> Exp -> Type -> Exp
ExpTypeSig (Exp -> Exp
forall a. MakeStrict a => a -> a
makeStrict Exp
e) Type
t
      NegApp Exp
e        -> Exp -> Exp
NegApp (Exp -> Exp
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 (Pat -> Pat
forall a. MakeStrict a => a -> a
makeStrict Pat
pat) (Rhs -> Rhs
forall a. MakeStrict a => a -> a
makeStrict Rhs
rhs) (Maybe Binds -> Maybe Binds
forall a. MakeStrict a => a -> a
makeStrict Maybe Binds
wh)