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