SKI.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}

module Zwirn.Language.Evaluate.SKI
  ( evaluate,
    compile,
    (!),
    removePosExp,
  )
where

{-
    SKI.hs - evaluate epxressions via the SKI combinator calculus,
    code adapted from https://kseo.github.io/posts/2016-12-30-write-you-an-interpreter.html
    Copyright (C) 2023, Martin Gius

    This library is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this library.  If not, see <http://www.gnu.org/licenses/>.
-}

import Data.Maybe (fromJust)
import Data.Text (unpack)
import Zwirn.Core.Cord
import Zwirn.Core.Core
import Zwirn.Core.Lib.Core
import Zwirn.Core.Lib.Modulate
import Zwirn.Core.Lib.Random (chooseWithSeed)
import Zwirn.Core.Types
import Zwirn.Language.Environment
import Zwirn.Language.Evaluate.Convert
import Zwirn.Language.Evaluate.Expression
import Zwirn.Language.Location
import Zwirn.Language.Simple
import Zwirn.Language.TypeCheck.Types

compile :: LocSimpleTerm -> Expression
compile (Located p (SVar n)) = EVar (Located p n)
compile (Located _ (SApp fun arg)) = EApp (compile fun) (compile arg)
compile (Located _ (SLambda x body)) = abstract x (compile body)
compile (Located p (SNum x)) = EZwirn $ addInfo p $ pure $ ENum $ read $ unpack x
compile (Located p (SText x)) = EZwirn $ addInfo p $ pure $ EText x
compile (Located _ (SSeq xs)) = ESeq $ map compile xs
compile (Located _ (SStack xs)) = EStack $ map compile xs
compile (Located _ (SChoice i xs)) = EChoice i $ map compile xs
compile (Located _ (SInfix s1 n s2)) = EApp (EApp (EVar n) (compile s1)) (compile s2)
compile (Located _ (SBracket s)) = compile s
compile (Located _ SRest) = EZwirn silence

abstract :: Name -> Expression -> Expression
abstract x (EVar n) | x == lValue n = combI
abstract x (EApp fun arg) = combS (abstract x fun) (abstract x arg)
abstract x (ESeq xs) = ESeq $ map (abstract x) xs
abstract x (EStack xs) = EStack $ map (abstract x) xs
abstract x (EChoice i xs) = EChoice i $ map (abstract x) xs
abstract _ k = combK k

combS :: Expression -> Expression -> Expression
combS f = EApp (EApp (EVar $ noLoc "scomb") f)

combK :: Expression -> Expression
combK = EApp (EVar $ noLoc "const")

combI :: Expression
combI = EVar (noLoc "id")

infixl 0 !

(!) :: Expression -> Expression -> Expression
(EZwirn fp) ! (EZwirn x) = EZwirn $ apply (fmap (\(ELam f) -> toZwirn . f . fromZwirn) fp) x
_ ! _ = error "Error in (!)"

link :: InterpreterEnv -> Expression -> Expression
link bs (EVar n) = addPosExp (lLoc n) $ fromJust (lookupExp (lValue n) bs)
-- link bs (EVar  n) = fromJust (lookupExp n bs)
link bs (EApp f x) = link bs f ! link bs x
link bs (ESeq xs) = EZwirn $ fastcat $ map (toZwirn . link bs) xs
link bs (EStack xs) = EZwirn $ stack $ map (toZwirn . link bs) xs
link bs (EChoice i xs) = EZwirn $ chooseWithSeed i $ map (toZwirn . link bs) xs
link _ e = e

evaluate :: InterpreterEnv -> LocSimpleTerm -> Expression
evaluate bs = link bs . compile

addPosExp :: SrcLoc -> Expression -> Expression
addPosExp p (EZwirn x) = EZwirn $ withInfos (p :) x
addPosExp _ x = x

removePosExp :: Expression -> Expression
removePosExp (EZwirn z) = EZwirn $ removeInfo z
removePosExp x = x