-{-# LANGUAGE MultiParamTypeClasses, GADTs, FlexibleContexts, FlexibleInstances, TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses, GADTs, FlexibleContexts, FlexibleInstances, TypeFamilies, RankNTypes #-}
-----------------------------------------------------------------------------
-- |
-- Module : GArrowSkeleton
-- behavior below -- you'd get (GAS_comp f GAS_id) instead of f. In
-- practice this means that the user must be prepared for the skeleton
-- TikZ diagram to be a nondeterministically-chosen boxes-and-wires
--- diagram which ks *equivalent to* the term, rather than structurally
+-- diagram which is *equivalent to* the term, rather than structurally
-- exactly equal to it.
--
-module GArrowSkeleton (GArrowSkeleton(..), optimize, beautify)
+-- A normal form theorem and normalization algorithm are being prepared.
+--
+module GArrowSkeleton (GArrowSkeleton(..), mkSkeleton, OptimizeFlag(..), optimize, beautify)
where
import Prelude hiding ( id, (.), lookup, repeat )
import Control.Category
-import GHC.HetMet.GArrow
+import Control.GArrow
import Unify
import Control.Monad.State
+import GArrowInclusion
data GArrowSkeleton m :: * -> * -> *
where
type instance GArrowUnit (GArrowSkeleton m) = ()
type instance GArrowExponent (GArrowSkeleton m) = (->)
-instance GArrowSTKCL (GArrowSkeleton m)
+instance GArrowCopyDropSwapLoop (GArrowSkeleton m)
+
+instance GArrowInclusion (GArrowSkeleton m) (,) () m where
+ ga_inc = GAS_misc
--
-- | Simple structural equality on skeletons. NOTE: two skeletons
GAS_unassoc === GAS_unassoc = True
(GAS_loopl f) === (GAS_loopl f') = f === f'
(GAS_loopr f) === (GAS_loopr f') = f === f'
+ (GAS_misc _) === (GAS_misc _) = True -- FIXME
_ === _ = False
- -- FIXME: GAS_misc's are never equal!!!
+
+data OptimizeFlag = DoOptimize | NoOptimize
+
+mkSkeleton :: OptimizeFlag ->
+ (forall g .
+ (GArrow g (,) ()
+ ,GArrowCopy g (,) ()
+ ,GArrowDrop g (,) ()
+ ,GArrowSwap g (,) ()
+ ,GArrowLoop g (,) ()
+ ,GArrowInclusion g (,) () m) =>
+ g x y)
+ -> GArrowSkeleton m x y
+mkSkeleton DoOptimize = \g -> (beautify . optimize) g
+mkSkeleton NoOptimize = \g -> g
+
+
--
-- | Performs some very simple-minded optimizations on a