src/Symantic/Parser/Haskell/View.hs

   1 {-# LANGUAGE DerivingStrategies #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE StandaloneDeriving #-}
   4 {-# OPTIONS_GHC -fno-warn-orphans #-}
   5 module Symantic.Parser.Haskell.View where
   6
   7 import Data.Bool
   8 import Data.Function (($), (.))
   9 import Data.Int (Int)
  10 import Data.Semigroup (Semigroup(..))
  11 import Data.String (IsString(..), String)
  12 import Prelude ((+))
  13 import Text.Show (Show(..), ShowS, shows, showParen, showString)
  14 import qualified Data.Function as Fun
  15
  16 import Symantic.Parser.Grammar.Fixity
  17 import qualified Symantic.Parser.Haskell.Optimize as H
  18
  19 -- * Type 'ViewTerm'
  20 newtype ViewTerm a = ViewTerm { unViewTerm ::
  21   ViewTermInh -> ShowS }
  22
  23 instance IsString (ViewTerm a) where
  24   fromString s = ViewTerm $ \_inh -> showString s
  25
  26 -- ** Type 'ViewTermInh'
  27 data ViewTermInh
  28  =   ViewTermInh
  29  {   viewTermInh_op :: (Infix, Side)
  30  ,   viewTermInh_pair :: Pair
  31  ,   viewTermInh_lamDepth :: Int
  32  }
  33
  34 pairViewTerm :: ViewTermInh -> Infix -> ShowS -> ShowS
  35 pairViewTerm inh op s =
  36   if isPairNeeded (viewTermInh_op inh) op
  37   then showString o . s . showString c
  38   else s
  39   where (o,c) = viewTermInh_pair inh
  40
  41 instance Show (ViewTerm a) where
  42   showsPrec p v = unViewTerm v ViewTermInh
  43     { viewTermInh_op = (infixN p, SideL)
  44     , viewTermInh_pair = pairParen
  45     , viewTermInh_lamDepth = 1
  46     }
  47 instance Show (H.Term repr a) where
  48   showsPrec p = showsPrec p . go
  49     where
  50     go :: forall b. H.Term repr b -> ViewTerm b
  51     go = \case
  52       H.Term{} -> "Term"
  53       {-
  54       (H.:.) H.:@ f H.:@ g -> ViewTerm $ \inh ->
  55         pairViewTerm inh op Fun.$
  56           unViewTerm (go f) inh{viewTermInh_op=op} Fun..
  57           showString " . " Fun..
  58           unViewTerm (go g) inh{viewTermInh_op=op}
  59         where op = infixR 9
  60       (H.:.) -> "(.)"
  61       -}
  62       {-
  63       H.Char t -> ViewTerm $ \_inh ->
  64         showString "(char " .
  65         shows t .
  66         showString ")"
  67       -}
  68       H.Char t -> ViewTerm $ \_inh -> shows t
  69       H.Cons H.:@ x H.:@ xs -> ViewTerm $ \inh ->
  70         pairViewTerm inh op Fun.$
  71           unViewTerm (go x) inh{viewTermInh_op=(op, SideL)} Fun..
  72           showString " : " Fun..
  73           unViewTerm (go xs) inh{viewTermInh_op=(op, SideR)}
  74         where op = infixN 5
  75       H.Cons -> "cons"
  76       H.Eq H.:@ x H.:@ y -> ViewTerm $ \inh ->
  77         pairViewTerm inh op Fun.$
  78           unViewTerm (go x) inh{viewTermInh_op=(op, SideL)} Fun..
  79           showString " == " Fun..
  80           unViewTerm (go y) inh{viewTermInh_op=(op, SideR)}
  81         where op = infixN 4
  82       H.Eq H.:@ x -> ViewTerm $ \inh ->
  83         showParen True Fun.$
  84           unViewTerm (go x) inh{viewTermInh_op=(op, SideL)} Fun..
  85           showString " =="
  86           where op = infixN 4
  87       H.Eq -> "(==)"
  88       H.Var v -> fromString v
  89       H.Lam1 f -> viewLam "u" f
  90       H.Lam f -> viewLam "x" f
  91       f H.:@ x -> ViewTerm $ \inh ->
  92         pairViewTerm inh op $
  93           unViewTerm (go f) inh{viewTermInh_op = (op, SideL) } .
  94           -- showString " :@ " .
  95           showString " " .
  96           unViewTerm (go x) inh{viewTermInh_op = (op, SideR) }
  97         where op = infixN 10
  98       {-
  99       H.Const -> "const"
 100       H.Flip -> "flip"
 101       H.Id -> "id"
 102       (H.:$) -> "($)"
 103       -}
 104     viewLam :: forall b c. String -> (H.Term repr b -> H.Term repr c) -> ViewTerm (b -> c)
 105     viewLam v f = ViewTerm $ \inh ->
 106       pairViewTerm inh op $
 107         let x = v<>show (viewTermInh_lamDepth inh) in
 108         -- showString "Lam1 (" .
 109         showString "\\" . showString x . showString " -> " .
 110         (unViewTerm (go (f (H.Var x))) inh
 111           { viewTermInh_op = (op, SideL)
 112           , viewTermInh_lamDepth = viewTermInh_lamDepth inh + 1
 113           })
 114         -- . showString ")"
 115       where op = infixN 0