Adapt the 'definitive-base' library to allow cross-compiling towards a...

Adapt the 'definitive-base' library to allow cross-compiling towards a JavaScript runtime with the Haste compiler

capricon/exe/WiQEE.hs

@@ -94,6 +94,8 @@ hasteDict = cocDict ("0.8.1.2-js" :: String) getString getBytes setString setByt
 
 main :: IO ()
 main = JS.concurrent $ void $ do
+  JS.wait 200
+
   let runWordsState ws st = ($st) $ from (stateT.concatT) $^ do
         foldr (\w tl -> do
                   x <- runExtraState (getl endState)

capricon/src/CaPriCon/Run.hs

@@ -310,7 +310,11 @@ runCOCBuiltin COCB_InsertNodeDir = do
     st -> st
 
 type MaxDelta = Int
-data UniverseConstraints = UniverseConstraints MaxDelta [MaxDelta]
+type UniverseConstraint = [Maybe MaxDelta]
+data UniverseConstraints = UniverseConstraints [UniverseConstraint]
+instance Semigroup UniverseConstraints where
+  UniverseConstraints x + UniverseConstraints y = UniverseConstraints $ zipWith (zipWith (\_x _y -> zipWith max _x _y + _x + _y)) x y
+instance Monoid UniverseConstraints where zero = UniverseConstraints (repeat (repeat Nothing))
 data COCValue io str = COCExpr Int (Node str)
                      | COCNull | COCError str
                      | COCDir (NodeDir str ([str],StackVal str (COCBuiltin io str) (COCValue io str)))

definitive-base/definitive-base.cabal

@@ -16,7 +16,7 @@ extra-source-files:  ChangeLog.md
 cabal-version:       >=1.10
 
 library
-  exposed-modules:     Definitive, Algebra.Monad, Algebra.Functor, Algebra.Foldable, Algebra.Lens, Algebra.Subtractive, Algebra.Core, Algebra.Classes, Algebra.Traversable, Algebra.Applicative, Algebra.Arrow, Algebra.Monad.Error, Algebra.Monad.Foldable, Algebra.Monad.RWS, Algebra.Monad.Free, Algebra.Monad.State, Algebra.Monad.Writer, Algebra.Monad.Logic, Algebra.Monad.Base, Algebra.Monad.Cont, Algebra.Monad.Reader, Definitive.Base, Data.Containers, Data.Queue, Data.IOVar, Data.Probability, Data.TimeVal, Data.SExpr, Data.Containers.Sequence, IO.Time
+  exposed-modules:     Definitive, Algebra.Monad, Algebra.Functor, Algebra.Foldable, Algebra.Lens, Algebra.Subtractive, Algebra.Core, Algebra.Classes, Algebra.Traversable, Algebra.Applicative, Algebra.Arrow, Algebra.Monad.Error, Algebra.Monad.Foldable, Algebra.Monad.RWS, Algebra.Monad.Free, Algebra.Monad.State, Algebra.Monad.Writer, Algebra.Monad.Logic, Algebra.Monad.Base, Algebra.Monad.Cont, Algebra.Monad.Reader, Definitive.Base, Data.Containers, Data.IOVar, Data.Probability, Data.TimeVal, Data.SExpr, Data.Containers.Sequence
   -- other-modules:
   default-extensions: TypeSynonymInstances,
                       NoMonomorphismRestriction,
@@ -33,6 +33,9 @@ library
                       AllowAmbiguousTypes,
                       RoleAnnotations
   other-extensions:    ImplicitParams, StandaloneDeriving, MultiParamTypeClasses, RankNTypes, DefaultSignatures, TupleSections, Rank2Types, FunctionalDependencies, ViewPatterns, LiberalTypeSynonyms, NoRebindableSyntax, EmptyDataDecls, CPP, ScopedTypeVariables, UndecidableInstances, DeriveGeneric, ExistentialQuantification, RecursiveDo, DeriveDataTypeable
-  build-depends: base >=4.9 && <4.10,bytestring >=0.10 && <0.11,clock >=0.7 && <0.8,containers >=0.5 && <0.6,deepseq >=1.4 && <1.5,vector >=0.12 && <0.13
+  build-depends: base >=4.8 && <4.10,bytestring >=0.10 && <0.11,containers >=0.5 && <0.6,deepseq >=1.4 && <1.5
+  if !impl(haste)
+    build-depends: clock >=0.7 && <0.8,vector >=0.12 && <0.13
+    exposed-modules: IO.Time, Data.Queue
   hs-source-dirs:      src
   default-language:    Haskell2010

definitive-base/src/Algebra/Applicative.hs

@@ -97,6 +97,13 @@ instance SemiApplicative (Zip []) where
           zip_ _ _ = []
 instance Applicative (Zip []) where
 
+instance Unit (Zip Maybe) where
+  pure a = Zip (Just a)
+instance SemiApplicative (Zip Maybe) where
+  Zip (Just zf) <*> Zip (Just zx) = Zip (Just (zf zx))
+  _ <*> _ = Zip Nothing
+instance Applicative (Zip Maybe)
+  
 instance Unit (Zip Tree) where
   pure a = Zip (Node a (deZip (pure (pure a))))
 instance SemiApplicative (Zip Tree) where

definitive-base/src/Algebra/Classes.hs

 {-# LANGUAGE DefaultSignatures, ScopedTypeVariables, CPP #-}
-#if MIN_VERSION_base(4,9,0)
+#if MIN_VERSION_base(4,8,0)
 {-# LANGUAGE TypeFamilies #-}
 #endif
 module Algebra.Classes where

definitive-base/src/Data/Containers/Sequence.hs

@@ -2,14 +2,16 @@
 module Data.Containers.Sequence (
   Sequence(..),Stream(..),i'elems,take,drop,dropping,
 
+  takeWhile,takeUntil,dropWhile,dropUntil,pry,
+  span,break,
+  (++),
+
+#ifndef __HASTE__
   -- * Strict and lazy slices (bytestrings on arbitrary Storable types)
   Slice,Slices,slice,slices,i'storables,_Slices,breadth,
 
-  V.unsafeWith,sliceElt,span,break,
-
-  takeWhile,takeUntil,dropWhile,dropUntil,pry,
-
-  (++)
+  V.unsafeWith,sliceElt
+#endif
   ) where
 
 import Definitive.Base
@@ -19,11 +21,13 @@ import qualified Data.ByteString.Lazy as Bytes
 import qualified Data.ByteString as Chunk
 import qualified Data.ByteString.Char8 as Char8
 import qualified Data.ByteString.Internal as BSI
+import qualified Prelude as P
+import Unsafe.Coerce (unsafeCoerce)
+#ifndef __HASTE__
 import qualified Data.Vector.Storable as V
 import Foreign.Storable (sizeOf)
-import qualified Prelude as P
 import Foreign.ForeignPtr (ForeignPtr,castForeignPtr)
-import Unsafe.Coerce (unsafeCoerce)
+#endif
 
 class Monoid t => Sequence t where
   splitAt :: Int -> t -> (t,t)
@@ -35,9 +39,6 @@ drop = map2 snd splitAt
 dropping :: Sequence t => Int -> Lens' t t
 dropping n = lens (drop n) (\x y -> take n x+y)
 
-instance V.Storable a => Semigroup (V.Vector a) where (+) = (V.++)
-instance V.Storable a => Monoid (V.Vector a) where zero = V.empty
-  
 instance Sequence [a] where
   splitAt n l = (h,t)
     where ~(h,t) = case (n,l) of
@@ -49,8 +50,6 @@ instance Sequence Bytes where
   splitAt = Bytes.splitAt . fromIntegral
 instance Sequence Chunk where
   splitAt = Chunk.splitAt . fromIntegral
-instance V.Storable a => Sequence (V.Vector a) where
-  splitAt = V.splitAt
 
 class Stream c s | s -> c where
   uncons :: s -> Maybe (c,s)
@@ -66,6 +65,47 @@ instance Stream Word8 Bytes where
   uncons = Bytes.uncons
   cons = Bytes.cons
 
+span :: Stream c s => (c -> Bool) -> s -> ([c],s)
+span p = fix $ \f s -> (case uncons s of
+                             Just (a,t) | p a -> let ~(l,t') = f t in (a:l,t')
+                             _ -> ([],s))
+break :: Stream c s => (c -> Bool) -> s -> ([c],s)
+break = span . map not
+
+takeWhile :: Stream c s => (c -> Bool) -> s -> [c]
+takeWhile p = fst . span p
+dropWhile :: Stream c s => (c -> Bool) -> s -> s
+dropWhile p = snd . span p
+takeUntil :: Stream c s => (c -> Bool) -> s -> [c]
+takeUntil = takeWhile . map not
+dropUntil :: Stream c s => (c -> Bool) -> s -> s
+dropUntil = dropWhile . map not
+
+pry :: Stream c s => Int -> s -> ([c],s)
+pry 0 s = ([],s)
+pry n s = case uncons s of
+  Just (a,s') -> let ~(t,l') = pry (n-1) s' in (a:t,l')
+  Nothing -> ([],s)
+
+(++) :: Stream c s => [c] -> s -> s
+(a:t) ++ c = cons a (t++c)
+[] ++ c = c
+
+i'elems :: (Monoid s',Stream c s,Stream c' s') => Iso [c] [c'] s s'
+i'elems = iso (takeUntil (const False)) (++zero)
+
+newtype StreamC a = StreamC (forall x. (a -> x -> x) -> x)
+
+instance Stream a (StreamC a) where
+  cons a (StreamC l) = StreamC (\c -> c a (l c))
+  uncons (StreamC l) = Just (l const,l (flip const))
+
+#ifndef __HASTE__
+instance V.Storable a => Semigroup (V.Vector a) where (+) = (V.++)
+instance V.Storable a => Monoid (V.Vector a) where zero = V.empty
+instance V.Storable a => Sequence (V.Vector a) where
+  splitAt = V.splitAt
+
 type Slice a = V.Vector a
 i'storables :: forall a b. (V.Storable a,V.Storable b) => Iso (Slice a) (Slice b) Chunk Chunk
 i'storables = iso toV fromV
@@ -113,37 +153,4 @@ sliceElt f = V.mapM (unsafeCoerce f) <&> runPMonad
 breadth :: V.Storable a => Slices a -> Int
 breadth s = s^.._Slices & foldMap V.length
 
-span :: Stream c s => (c -> Bool) -> s -> ([c],s)
-span p = fix $ \f s -> (case uncons s of
-                             Just (a,t) | p a -> let ~(l,t') = f t in (a:l,t')
-                             _ -> ([],s))
-break :: Stream c s => (c -> Bool) -> s -> ([c],s)
-break = span . map not
-
-takeWhile :: Stream c s => (c -> Bool) -> s -> [c]
-takeWhile p = fst . span p
-dropWhile :: Stream c s => (c -> Bool) -> s -> s
-dropWhile p = snd . span p
-takeUntil :: Stream c s => (c -> Bool) -> s -> [c]
-takeUntil = takeWhile . map not
-dropUntil :: Stream c s => (c -> Bool) -> s -> s
-dropUntil = dropWhile . map not
-
-pry :: Stream c s => Int -> s -> ([c],s)
-pry 0 s = ([],s)
-pry n s = case uncons s of
-  Just (a,s') -> let ~(t,l') = pry (n-1) s' in (a:t,l')
-  Nothing -> ([],s)
-
-(++) :: Stream c s => [c] -> s -> s
-(a:t) ++ c = cons a (t++c)
-[] ++ c = c
-
-i'elems :: (Monoid s',Stream c s,Stream c' s') => Iso [c] [c'] s s'
-i'elems = iso (takeUntil (const False)) (++zero)
-
-newtype StreamC a = StreamC (forall x. (a -> x -> x) -> x)
-
-instance Stream a (StreamC a) where
-  cons a (StreamC l) = StreamC (\c -> c a (l c))
-  uncons (StreamC l) = Just (l const,l (flip const))
+#endif -- __HASTE__

definitive-base/src/Definitive.hs

-{-# LANGUAGE ImplicitParams, StandaloneDeriving #-}
+{-# LANGUAGE ImplicitParams, StandaloneDeriving, CPP #-}
 module Definitive (
   module Definitive.Base,
   module Data.Containers,